current state of pallet.compute.vmfest

gistfile1.clj

(ns pallet.compute.vmfest
  "A vmfest provider"
  (:require
   [pallet.compute :as compute]
   [pallet.compute.jvm :as jvm]
   [pallet.compute.implementation :as implementation]
   [clojure.contrib.condition :as condition]
   [clojure.string :as string]
   [vmfest.virtualbox.vbox :as vbox]
   [vmfest.machine :as machine])
  (:import
   com.sun.xml.ws.commons.virtualbox_3_2.IMedium
   com.sun.xml.ws.commons.virtualbox_3_2.IMachine))

(defn supported-providers []
  ["virtualbox"])

(defn machine-task [f]
  "Create a task that will be invoked with a machine"
  (fn [session]
    (let [mutable-machine (.getMachine session)]
      (f mutable-machine))))

(defn execute-task-with-return-value
  "Execute a task, capturing the return value."
  [machine task]
  (let [return-value (atom nil)
        latch (java.util.concurrent.CountDownLatch. 1)]
    (machine/execute-task
     machine
     #(do
        (try
          (reset! return-value (task %))
          (finally
           (.countDown latch)))))
     (.await latch)
     @return-value))

(def os-family-name
  {:ubuntu "Ubuntu"
   ;:rhel "RedHat"
   :rhel "RedHat_64"})

(def os-family-from-name
  (zipmap (vals os-family-name) (keys os-family-name)))

(extend-type vmfest.virtualbox.vbox.vbox-machine
  pallet.compute/Node
  (ssh-port [node] 22)
  (primary-ip [node] "")
  (private-ip [node] "")
  (is-64bit?
   [node]
   (re-find
    #"64 bit"
    (execute-task-with-return-value
      node (machine-task #(.getOSTypeId %)))))
  (tag [node] "")
  (hostname
   [node]
   (execute-task-with-return-value
     node (machine-task #(.getName %))))
  (os-family
   [node]
   (let [os-name (execute-task-with-return-value
                   node (machine-task #(.getOSTypeId %)))]
     (os-family-from-name os-name os-name)))
  (running? [node] true)
  (terminated? [node] false)
  (id [node] ""))


(defn connection
  [host port identity credential]
  (let [manager (#'vmfest.virtualbox.vbox/create-session-manager host port)
        virtual-box (#'vmfest.virtualbox.vbox/create-vbox
                     manager identity credential)]
    [manager virtual-box]))

(defn find-matching-os [node-type os-types]
  (let [os-family (or (-> node-type :image :os-family) :ubuntu)
        os-type-id (os-family-name os-family)
        os-type (first (filter #(= os-type-id (.getId %)) os-types))]
    (if os-type
      (.getId os-type)
      (throw (Exception. "Can not find a matching os type")))))

(defn find-matching-machines [os-type-id machines]
  (filter #(= os-type-id (.getOSTypeId %)) machines))

(defprotocol VirtualBoxService
  (os-families [compute] "Return supported os-families")
  (medium-formats [compute] "Return supported medium-formats"))

(deftype VirtualBox [host port identity credential]
  VirtualBoxService
  (os-families
   [compute]
   (let [[manager virtual-box] (connection host port identity credential)]
     (try
       (.getGuestOSTypes virtual-box)
       (finally
        (.logoff manager virtual-box)))))
  (medium-formats
   [compute]
   (let [[manager virtual-box] (connection host port identity credential)]
     (.. virtual-box getSystemProperties getMediumFormats)))

  pallet.compute.ComputeService
  (nodes
   [compute-service]
   (let [[manager virtual-box] (connection host port identity credential)]
     (try
       (doall
        (map
         #(vbox/build-vbox-machine host port identity credential (.getId %))
         (.getMachines virtual-box)))
       (finally
        (.logoff manager virtual-box)))))
  (ensure-os-family
   [compute-service request]
   request)
  ;; Not implemented
  ;; (build-node-template)
  (run-nodes
   [compute node-type node-count request init-script]
   (let [[manager virtual-box] (connection host port identity credential)
         os-type-id (find-matching-os node-type (.getGuestOSTypes virtual-box))
         all-machines (.getMachines virtual-box)
         machines (find-matching-machines os-type-id all-machines)
         template-machine (first machines)
         storage-controller (first (.getStorageControllers template-machine))
         ^IMedium base-medium (.getMedium
                               template-machine
                               (.getName storage-controller) 0 0)
         base-folder nil
         tag-name (name (:tag node-type))
         machine-name (some
                       (fn [i]
                         (let [n (str tag-name i)]
                           (when-not (some #(= n (.getName %)) all-machines)
                             n)))
                       (range))
         id nil
         override false
         ^IMachine machine (.createMachine
                            virtual-box
                            machine-name os-type-id base-folder id override)
         vdi (first
              (filter #(= "VDI" (.getName %))
                      (.. virtual-box getSystemProperties getMediumFormats)))
         ^IMedium medium (.createHardDisk
                          virtual-box
                          (.getId vdi)
                          (format
                           "/Volumes/My Book/vms/diffdisks/%s.vdi"
                           machine-name))
         ;; _ (.createDiffStorage
         ;;    base-medium medium org.virtualbox_3_2.MediumVariant/DIFF)
         clone-progress (.cloneTo
                         base-medium medium
                         org.virtualbox_3_2.MediumVariant/DIFF
                         base-medium)]
     (vbox/set-attributes {} machine)
     (.saveSettings machine)
     (.addStorageController machine "IDE" org.virtualbox_3_2.StorageBus/IDE)
     (.registerMachine virtual-box machine)
     (.waitForCompletion clone-progress 10000)
     (loop []
       (let [m1 (try
                  (when-not (= (.getId medium) (java.util.UUID. 0 0))
                    (.getHardDisk virtual-box (.getId medium)))
                  (catch Throwable _
                    nil))]
         (when-not m1
           (Thread/sleep 500)
           (recur))))
     (let [machine (vbox/build-vbox-machine host port identity credential
                                            (.getId machine))]
       (machine/execute-task
        machine
        (machine-task
         #(do
            (.attachDevice
             %
             "IDE"
             0 0
             org.virtualbox_3_2.DeviceType/HARD_DISK
             (.getId medium))
            (.saveSettings %))))
       machine))

   ;; (dotimes [_ node-count]
   ;;   (vmfest/start-vm connection virtual-box "image"))
   )
  ;; (reboot "Reboot the specified nodes")
  (boot-if-down
   [compute nodes]
   (doseq [node nodes]
     (let [^com.sun.xml.ws.commons.virtualbox_3_2.ISession
           session (#'vmfest.virtualbox.vbox/get-session node)
           virtual-box (#'vmfest.virtualbox.vbox/get-vbox node)
           uuid (:machine-id node)
           session-type "vrdp"
           env "DISPLAY:0.0"
           progress (.openRemoteSession
                     virtual-box session uuid session-type env)]
       ;(with-open [session session])
       (println "Session for VM" uuid "is opening...")
       (.waitForCompletion progress 10000)
       (let [result-code (.getResultCode progress)]
         (if (zero? result-code)
           nil
           true)))))

  (shutdown-node
   [compute node _]
   (machine/execute-task
    node
    (fn [session]
      (let [machine (.getMachine session)
            console (.getConsole session)]
        (when (#{org.virtualbox_3_2.MachineState/RUNNING
                 org.virtualbox_3_2.MachineState/PAUSED
                 org.virtualbox_3_2.MachineState/STUCK} (.getState machine))
          (let [ progress (.powerDown console)]
            (.waitForCompletion progress 10000)))))))

  ;; (shutdown "Shutdown specified nodes")
  (destroy-nodes-with-tag [compute tag-name])
  (destroy-node
   [compute node]
   )
  (close [compute])
  )

;;;; Compute service
(defmethod implementation/service :virtualbox
  [_ {:keys [host port identity credential]
      :or {host "localhost"
           port "18083"
           username "test"
           password "test"}
      :as options}]
  (VirtualBox. host port identity credential))