Added support for first-class nodes and tagging.

The session endpoint changes, client suppport, and documentation are
still in-progress.

Refs #3, #18.

src/shale/node_pools.clj

@@ -0,0 +1,78 @@
+(ns shale.node-pools
+  (:import java.io.FileNotFoundException))
+
+(try
+  (require '[amazonica.aws.ec2])
+  (catch FileNotFoundException e))
+
+(defprotocol INodePool
+  "Basic interface for choosing and managing Selenium nodes per session.
+   Implementing this allows dynamic node domains- eg, by retrieving them from
+   a cloud provider's API."
+
+  (get-nodes [this])
+
+  (add-node [this url]
+    "Add a new node to the pool. If a url is provided, stick with that. Otherwise
+    attempt to create a new node.")
+  (remove-node [this url]
+    "Remove a node from the pool specific by url.")
+  (can-add-node [this]
+    "Whether this pool supports adding new nodes.")
+  (can-remove-node [this]
+    "Whether this pool supports removing nodes."))
+
+(deftype DefaultNodePool [nodes]
+  INodePool
+  ;;A simple node pool that chooses randomly from an initial list.
+  (get-nodes [this]
+    nodes)
+
+  (add-node [this requirements]
+    (throw (ex-info "Unable to add new nodes to the default node pool."
+                    {:user-visible true :status 500})))
+
+  (remove-node [this url]
+    (throw (ex-info "Unable to remove nodes with the default node pool."
+                    {:user-visible true :status 500})))
+
+  (can-add-node [this] false)
+  (can-remove-node [this] false))
+
+(defn ^:private describe-instances-or-throw []
+  (let [describe-instances
+            (ns-resolve 'amazonica.aws.ec2 'describe-instances)]
+        (if describe-instances
+          (mapcat #(get % :instances) (get (describe-instances) :reservations))
+          (throw
+            (ex-info
+              (str "Unable to configure connect to the AWS API- make sure "
+                   "amazonica is listed in your dependencies.")
+              {:user-visible true :status 500})))))
+
+(defn ^:private instances-running-shale []
+  (filter #(and
+             (= (get-in % [:state :name]) "running")
+             (some (fn [i] (= (get i :key) "shale"))
+                   (get % :tags)))
+          (describe-instances-or-throw)))
+
+(defn ^:private instance->node-url [instance use-private-dns]
+  (format "http://%s:5555/wd/hub"
+          (get instance
+               (if use-private-dns :private-dns-name :public-dns-name))))
+
+(deftype AWSNodePool [options]
+    INodePool
+
+    (get-nodes [this]
+      (map #(instance->node-url % (get options :use-private-dns))
+           (instances-running-shale)))
+    (add-node [this url]
+      (throw (ex-info "Adding nodes is not yet implemented."
+                      {:user-visible true :status 500})))
+
+    (remove-node [this url])
+
+    (can-add-node [this] false)
+    (can-remove-node [this] false))

src/shale/nodes.clj

@@ -1,88 +1,127 @@
 (ns shale.nodes
-  (:import java.io.FileNotFoundException))
-
-(try
-  (require '[amazonica.aws.ec2])
-  (catch FileNotFoundException e))
-
-(defprotocol INodePool
-  "Basic interface for choosing and managing Selenium nodes per session.
-   Implementing this allows dynamic node domains- eg, by retrieving them from
-   a cloud provider's API."
-
-  (get-nodes [this])
-
-  (get-node [this requirements]
-    "Get a node from the pool. Takes the same requirement map as
-     get-or-create-session.")
-  (add-node [this requirements]
-    "Add a node to the pool that fulfills the requirement map.")
-  (remove-node [this url]
-    "Remove a node from the pool specific by url.")
-  (can-add-node [this]
-    "Whether this pool supports adding new nodes.")
-  (can-remove-node [this]
-    "Whether this pool supports remove nodes."))
-
-(deftype DefaultNodePool [nodes]
-  INodePool
-  ;;A simple node pool that chooses randomly from an initial list.
-  (get-nodes [this])
-
-  (get-node [this requirements]
-    (rand-nth nodes))
-
-  (add-node [this requirements]
-    (throw (ex-info "Unable to add new nodes to the default node pool."
-                    {:user-visible true :status 500})))
-
-  (remove-node [this requirements]
-    (throw (ex-info "Unable to remove nodes with the default node pool."
-                    {:user-visible true :status 500})))
-
-  (can-add-node [this] false)
-  (can-remove-node [this] false))
-
-(defn describe-instances-or-throw []
-  (let [describe-instances
-            (ns-resolve 'amazonica.aws.ec2 'describe-instances)]
-        (if describe-instances
-          (mapcat #(get % :instances) (get (describe-instances) :reservations))
-          (throw
-            (ex-info
-              (str "Unable to configure connect to the AWS API- make sure "
-                   "amazonica is listed in your dependencies.")
-              {:user-visible true :status 500})))))
-
-(defn instances-running-shale []
-  (filter #(and
-             (= (get-in % [:state :name]) "running")
-             (some (fn [i] (= (get i :key) "shale"))
-                   (get % :tags)))
-          (describe-instances-or-throw)))
-
-(defn instance->node-url [instance use-private-dns]
-  (format "http://%s:5555/wd/hub"
-          (get instance
-               (if use-private-dns :private-dns-name :public-dns-name))))
-
-(deftype AWSNodePool [options]
-    INodePool
-
-    (get-nodes [this]
-      (map instance->node-url (instances-running-shale)))
-
-    (get-node [this requirements]
-      (instance->node-url (rand-nth instances-running-shale)))
-
-    (add-node [this requirements]
-      (throw (ex-info "Adding nodes is not yet implemented."
-                      {:user-visible true :status 500})))
-
-    (remove-node [this requirements]
-      (throw (ex-info "Removing nodes is not yet implemented."
-                      {:user-visible true :status 500})))
-
-    (can-add-node [this] false)
-    (can-remove-node [this] false))
-
+  (:require [shale.node-pools :as node-pools]
+            [taoensso.carmine :as car :refer (wcar)])
+  (:use carica.core
+        shale.redis
+        shale.utils
+        [clojure.set :only  [difference]])
+  (:import java.util.UUID
+           [shale.node_pools DefaultNodePool AWSNodePool]))
+
+(deftype ConfigNodePool [])
+
+(def node-pool (if (nil? (config :node-pool-impl))
+                 (if (nil? (config :node-pool-cloud-config))
+                   (node-pools/DefaultNodePool. (or (config :node-list)
+                                               ["http://localhost:5555/wd/hub"]))
+                   (if (= ((config :node-pool-cloud-config) :provider) :aws)
+                     (node-pools/AWSNodePool. (config :node-pool-cloud-config))
+                     (throw (ex-info (str "Issue with cloud config: AWS is "
+                                          "the only currently supported "
+                                          "provider.")
+                                     {:user-visible true :status 500}))))
+                 (do
+                   (extend ConfigNodePool
+                     node-pools/INodePool
+                       (config :node-pool-impl))
+                   (ConfigNodePool.))))
+
+(def node-set-key
+  (apply str (interpose "/" [redis-key-prefix "nodes"])))
+
+(def node-key-template
+  (apply str (interpose "/" [redis-key-prefix "nodes" "%s"])))
+
+(def node-tags-key-template
+  (apply str (interpose "/" [redis-key-prefix "nodes" "%s" "tags"])))
+
+(defn node-key [id]
+  (format node-key-template id))
+
+(defn node-tags-key [id]
+  (format node-tags-key-template id))
+
+(defn node-ids []
+  (with-car* (car/smembers node-set-key)))
+
+(defn uuid [] (str (java.util.UUID/randomUUID)))
+
+(defn node-ids []
+  (with-car* (car/smembers node-set-key)))
+
+(defn view-model [id]
+  (let [node-key (node-key id)
+        node-tags-key (node-tags-key id)
+        [contents tags] (with-car*
+                          (car/hgetall node-key)
+                          (car/smembers node-tags-key))]
+    (assoc (apply hash-map contents) :tags (or tags []) :id id)))
+
+(defn view-models [ids]
+  (let [ids (or ids (node-ids) )]
+    (map view-model ids)))
+
+(defn view-model-from-url [url]
+  (first (filter #(= (% :url) url) (view-models nil))))
+
+(defn modify-node [id {:keys [url tags]
+                       :or {:url nil
+                            :tags nil}}]
+  (last
+    (with-car*
+      (let [node-key (node-key id)
+            node-tags-key (node-tags-key id)]
+        (if url (car/hset node-key :url url))
+        (if tags (sset-all node-tags-key tags))
+        (car/return (view-model id))))))
+
+(defn create-node [{:keys [url
+                           tags]
+                    :or {:tags []}}]
+  (last
+    (with-car*
+      (let [id (uuid)
+            node-key (node-key id)]
+        (car/sadd node-set-key id)
+        (modify-node id {:url url :tags tags})
+        (car/return (view-model id))))))
+
+(defn destroy-node [id]
+  (with-car*
+    (car/watch node-set-key)
+    (try
+      (node-pools/remove-node node-pool (get (view-model id) :url))
+      (finally
+        (car/srem node-set-key id)
+        (car/del (node-key id))
+        (car/del (node-tags-key id)))))
+  true)
+
+(defn ^:private to-set [s]
+  (into #{} s))
+
+(defn refresh-nodes
+  "Syncs the node list with the backing node pool."
+  []
+  (let [nodes (to-set (node-pools/get-nodes node-pool))
+        registered-nodes (to-set (map #(get % :url) (view-models nil)))]
+    (doall
+      (concat
+        (map #(create-node {:url %})
+             (difference nodes registered-nodes))
+        (map #(destroy-node ((view-model-from-url %) :id))
+             (difference registered-nodes nodes)))))
+  true)
+
+(defn get-node [{:keys [url
+                        tags]
+                 :or {:url nil
+                      :tags []}
+                 :as requirements}]
+  (let [matches-requirements (fn [model]
+                               (apply clojure.set/subset?
+                                      (map #(select-keys % [:url :tags])
+                                           [requirements model])))]
+    (first
+      (filter matches-requirements
+              (view-models nil)))))

src/shale/periodic.clj

@@ -1,11 +1,14 @@
 (ns shale.periodic
   (:require [shale.sessions :as sessions])
+  (:require [shale.nodes :as nodes])
   (:use overtone.at-at))
 
 (def thread-pool (mk-pool))
 
 (defn schedule! []
+  (every 10000 #(nodes/refresh-nodes) thread-pool :fixed-delay true)
   (every 200 #(sessions/refresh-sessions nil) thread-pool :fixed-delay true))
 
+
 (defn stop! []
   (stop-and-reset-pool! thread-pool))

src/shale/redis.clj

@@ -0,0 +1,15 @@
+(ns shale.redis
+  (:require [taoensso.carmine :as car :refer (wcar)])
+  (:use carica.core))
+
+(def redis-conn  {:pool {} :spec {}})
+(defmacro with-car*  [& body] `(car/wcar redis-conn ~@body))
+
+(def redis-key-prefix "_shale")
+
+(defn hset-all [k m]
+  (doall #(car/hset (key %) (val %)) m))
+
+(defn sset-all [k s]
+  (car/del k)
+  (doall (map #(car/sadd k %) s)))

src/shale/resources.clj

@@ -121,6 +121,38 @@
   :post! (fn [context]
            (shale.sessions/refresh-sessions (if (nil? id) id [id]))))
 
+(defresource nodes-resource [params]
+  :allowed-methods  [:get]
+  :available-media-types  ["application/json"]
+  :known-content-type? is-json-content?
+  :malformed? #(parse-json % ::data)
+  :handle-ok (fn [context]
+               (jsonify (shale.nodes/view-models nil))))
+
+(defresource nodes-refresh-resource []
+  :allowed-methods [:post]
+  :available-media-types ["application/json"]
+  :post! (fn [context]
+           (shale.nodes/refresh-nodes)))
+
+(defresource node-resource [id]
+  :allowed-methods [:get :put :delete]
+  :available-media-types ["application/json"]
+  :known-content-type? is-json-content?
+  :malformed? #(parse-json % ::data)
+  :handle-ok (fn [context]
+               (jsonify (get context ::node)))
+  :delete! (fn [context]
+             (shale.nodes/destroy-node id))
+  :put! (fn [context]
+          {::node
+           (shale.nodes/modify-node id (clojure-keys
+                                         (get context ::data)))})
+  :exists? (fn [context]
+             (let [node (shale.nodes/view-model id)]
+               (if-not (nil? node)
+                 {::node node}))))
+
 (defresource index
   :available-media-types ["text/html" "application/json"]
   :handle-ok (fn [context]
@@ -149,5 +181,10 @@
          (session-resource id))
     (ANY ["/sessions/:id/refresh", :id #"(?:[a-zA-Z0-9]{4,}-)*[a-zA-Z0-9]{4,}"]
          [id]
-         (sessions-refresh-resource id)))
+         (sessions-refresh-resource id))
+    (ANY "/nodes" {params :params} nodes-resource)
+    (ANY "/nodes/refresh" [] (nodes-refresh-resource))
+    (ANY ["/nodes/:id", :id #"(?:[a-zA-Z0-9\-])+"]
+         [id]
+         (node-resource id)))
    (dev/wrap-trace :ui :header)))