Source

clj-soap / src / clj_soap / core.clj

Full commit
(ns clj-soap.core
  (:use [clojure.contrib.core]))

;;; Defining SOAP Server

(defmacro defservice
  "Define SOAP class.
  i.e. (defsoap some.package.KlassName (myfunc [String a int b] String (str a (* b b))))"
  [class-name & method-defs]
  (let [prefix (str (gensym "prefix"))]
    `(do
       (gen-class
         :name ~class-name
         :prefix ~prefix
         :methods ~(vec (for [method-def method-defs]
                          (let [[method-name arglist & _] method-def]
                            [method-name
                             (vec (for [arg arglist]
                                    (or (:tag (meta arg)) String)))
                             (or (:tag (meta method-def)) 'void)]))))
       ~@(for [[method-name arglist & body] method-defs]
           `(defn ~(symbol (str prefix method-name))
              ~(vec (cons 'this arglist))
              ~@body)))))

(defn serve
  "Start SOAP server.
  argument classes is list of strings of classnames."
  [& classes]
  (let [server (org.apache.axis2.engine.AxisServer.)]
    (doseq [c classes]
      (.deployService server (str c)))))

;; Client call

(defn axis-service-namespace [axis-service]
  (.get (.getNamespaceMap axis-service) "ns"))

(defn axis-service-operations [axis-service]
  (iterator-seq (.getOperations axis-service)))

(defn axis-op-name [axis-op]
  (.getLocalPart (.getName axis-op)))

(defn axis-op-namespace [axis-op]
  (.getNamespaceURI (.getName axis-op)))

(defn axis-op-args [axis-op]
  (for [elem (-?> (first (filter #(= "out" (.getDirection %))
                                 (iterator-seq (.getMessages axis-op))))
                  .getSchemaElement .getSchemaType
                  .getParticle .getItems .getIterator iterator-seq)]
    {:name (.getName elem) :type (-?> elem .getSchemaType .getName keyword)}))

(defn axis-op-rettype [axis-op]
  (-?> (first (filter #(= "in" (.getDirection %))
                      (iterator-seq (.getMessages axis-op))))
       .getSchemaElement .getSchemaType .getParticle .getItems .getIterator
       iterator-seq first
       .getSchemaType .getName
       keyword))

(defn value-str [valobj argtype]
  (case argtype
    :integer (str valobj)
    :double (str valobj)
    :string (str valobj)
    :anyType (str valobj)
    :boolean (str valobj))) 

(defn get-result [op retelem]
  (let [ret-str (.getText (first (iterator-seq (.getChildElements retelem))))]
    (case (axis-op-rettype op)
      :integer (Integer/parseInt ret-str)
      :double (Double/parseDouble ret-str)
      :string ret-str
      :anyType ret-str
      :boolean (Boolean/parseBoolean ret-str))))

(defn make-client [url]
  (doto (org.apache.axis2.client.ServiceClient. nil (java.net.URL. url) nil nil)
    (.setOptions
      (doto (org.apache.axis2.client.Options.)
        (.setTo (org.apache.axis2.addressing.EndpointReference. url))))))

(defn make-request [op & args]
  (let [factory (org.apache.axiom.om.OMAbstractFactory/getOMFactory)
        request (.createOMElement
                  factory (javax.xml.namespace.QName.
                            (axis-op-namespace op) (axis-op-name op)))
        op-args (axis-op-args op)]
    (doseq [[argval argtype] (map list args op-args)]
      (.addChild request
                 (doto (.createOMElement
                         factory (javax.xml.namespace.QName. (:name argtype)))
                   (.setText (value-str argval (:type argtype))))))
    request))

(defn client-call [client op & args]
  (if (isa? (class op) org.apache.axis2.description.OutOnlyAxisOperation)
    (.sendRobust client (.getName op) (apply make-request op args))
    (get-result
      op (.sendReceive client (.getName op) (apply make-request op args)))))

(defn client-proxy [url]
  (let [client (make-client url)]
    (->> (for [op (axis-service-operations (.getAxisService client))]
               [(keyword (axis-op-name op))
                (fn soap-call [& args] (apply client-call client op args))])
      (into {}))))

(defn client-fn [url]
  (let [px (client-proxy url)]
    (fn [opname & args]
      (apply (px opname) args))))