git.fiddlerwoaroof.com
Raw Blame History
(ns co.fwoar.CrazyBean
  (:import [javax.management MBeanInfo AttributeList MBeanAttributeInfo
            MBeanOperationInfo MBeanParameterInfo])
  (:require [clojure.string :as str])
  (:gen-class
   :implements [javax.management.DynamicMBean]
   :init init
   :state state
   :constructors {[Object] []}))

(def ^{:private true} guess-attribute-map
  {"java.lang.Integer" "int"
   "java.lang.Boolean" "boolean"
   "java.lang.Long" "long"})

(defn- guess-attribute-typename
  "Guess the attribute typename for MBeanAttributeInfo based on the attribute value."
  [value]
  (let [classname (.getName (class value))]
    (get guess-attribute-map classname classname)))

(defn- build-attribute-info
  "Construct an MBeanAttributeInfo. Normally called with a key/value pair from a Clojure map."
  ([attr-name attr-value]
   (build-attribute-info
    (name attr-name)
    (guess-attribute-typename attr-value)
    (name attr-name) true false false))
  ([name type desc readable? writable? is?] (MBeanAttributeInfo. name type desc readable? writable? is? )))

(defn- map->attribute-infos
  "Construct an MBeanAttributeInfo[] from a Clojure associative."
  [attr-map]
  (into-array MBeanAttributeInfo
              (map (fn [[attr-name value]] (build-attribute-info attr-name value))
                   attr-map)))

;; todo mv to util
(defn zip [& cols] (apply map vector cols))

(defn unmangle
  "Given the name of a class that implements a Clojure function, returns the function's name in Clojure. Note: If the true Clojure function name
  contains any underscores (a rare occurrence), the unmangled name will
  contain hyphens at those locations instead."
  [class-name]
  (.replace (str/replace class-name #"^(.+)\$(.+)__\d+$" "$1/$2")
            \_ \-))

(defn fn-by-name
  "lookup string to fn at run time"
  [ns-symbol fn-name]
  (intern (clojure.lang.Namespace/find ns-symbol) (symbol (name fn-name))))
;; /util

(defn -init [derefable]
  [[] derefable])

(defn build-parameter-info [param opts]
  (let [{:keys [name type description]
         :or {name  (.getName param)
              type  (.getName param)
              description ""}} opts]
    (MBeanParameterInfo. name type description)))

(defn parameter-infos [params-seq]
  (into-array MBeanParameterInfo
   (map
    (fn [[i param]]
      (build-parameter-info param {:name (str "p" i)}))
    (zip (range 0 (count params-seq)) params-seq))))

(defn build-operation-info [ifn opts]
  (let [{:keys [name description argv return-type impact]
         :or {name         (unmangle (.getName (class ifn)))
              description  (unmangle (.getName (class ifn)))
              argv         nil
              return-type  "void"
              impact       MBeanOperationInfo/ACTION}} opts
         params (parameter-infos argv)]
   (MBeanOperationInfo. name description params return-type impact)))

(defn operation-infos [ops-seq]
  (into-array (map (fn [[ifn opts]] (build-operation-info ifn opts))
                   ops-seq)))

; TODO: rest of the arguments, as needed
(defn generate-mbean-info [clj-bean]
  (MBeanInfo.
   (.. clj-bean getClass getName)                     ; class name
   "Clojure Dynamic MBean"                            ; description
   (map->attribute-infos (dissoc @(.state clj-bean)   ; attributes
                                 :operations))
   nil                                                ; constructors
   (operation-infos (@(.state clj-bean) :operations)) ; operations
   nil))                                              ; notifications
(defn -getMBeanInfo
  [this]
  (generate-mbean-info this))

(defn -getAttribute
  [this attr]
  (@(.state this) (keyword attr)))

(defn -getAttributes
  [this attrs]
  (let [result (AttributeList.)]
    (doseq [attr attrs]
      (.add result (.getAttribute this attr)))
    result))

(defn -invoke [this name args sig]
  ;; this might be a huge security hole fyi
  ;; who knows what kind of havoc this could wreak!
  (let [[ns-name fn-name] (str/split name #"\$")
        ifn (fn-by-name (symbol ns-name) fn-name)]
    (apply ifn (seq args))))