Merge branch 'f/magicaldocs' into develop

Conflicts:
	project.clj
	src/wakeful/core.clj

project.clj

@@ -4,4 +4,6 @@
                  [useful "0.4.0"]
                  [org.clojars.lancepantz/clj-json "0.4.0"]
                  [compojure "0.6.3"]
-                 [ego "0.1.1-SNAPSHOT"]])
+                 [ego "0.1.1-SNAPSHOT"]
+                 [hiccup "0.3.5"]]
+  :dev-dependencies [[ring "0.3.8"]]) ; for some testing

src/wakeful/core.clj

@@ -4,9 +4,12 @@
         [useful.utils :only [verify]]
         [ring.middleware.params :only [wrap-params]]
         [clout.core :only [route-compile]]
-        [ego.core :only [split-id]])
+        [ego.core :only [split-id]]
+        wakeful.docs)
   (:require [clj-json.core :as json]))
 
+(defn foo [& all] "blah")
+
 (defn resolve-method [ns-prefix type method]
   (let [ns     (symbol (if type (str (name ns-prefix) "." (name type)) ns-prefix))
         method (symbol (if (string? method) method (apply str method)))]
@@ -23,13 +26,15 @@
 (defn- assoc-type [route-params]
   (assoc route-params :type (node-type (:id route-params))))
 
-(defn- wrap-json [handler]
-  (fn [{body :body :as request}]
-    (let [body (when body (json/parse-string (if (string? body) body (slurp body))))]
-      (when-let [response (handler (assoc request :body body :form-params {}))]
-        (-> response
-            (update :body json/generate-string)
-            (assoc-in [:headers "Content-Type"] "application/json; charset=utf-8"))))))
+(defn- wrap-content-type [handler content-type]
+  (let [json? (.startsWith content-type "application/json")
+        [fix-request fix-response] (if json?
+                                     [#(when % (-> % slurp json/parse-string))
+                                      #(update % :body json/generate-string)]
+                                     [identity identity])]
+    (fn [{body :body :as request}]
+      (when-let [response (handler (assoc request :body (fix-request body) :form-params {}))]
+        (fix-response (assoc-in response [:headers "Content-Type"] content-type))))))
 
 (defn- ns-router [ns-prefix wrapper & [method-suffix]]
   (fn [{{:keys [method type id]} :route-params :as request}]
@@ -39,7 +44,7 @@
         (method request)))))
 
 (defn route [pattern]
-  (route-compile pattern {:id #"\w+-\d+" :type #"\w+" :method #"[\w-]+"}))
+  (route-compile pattern {:id #"\w+-\d+" :type #"\w+" :method #"[\w-]+" :ns #".*"}))
 
 (defmacro READ [& forms]
   `(fn [request#]
@@ -111,11 +116,26 @@
             (POST "/bulk-write" {:as request}
                   (bulk-write request)))))
 
+(defn doc-routes [ns-prefix suffix]
+  (routes (GET "/docs" []
+               (generate-top ns-prefix suffix))
+
+          (GET (route "/docs/:ns") {{ns :ns} :params}
+               (generate-page ns-prefix ns suffix))))
+
 (defn wakeful [ns-prefix & opts]
-  (let [opts  (into-map opts)
-        read  (read-routes  (ns-router ns-prefix (:read  opts)))
-        write (write-routes (ns-router ns-prefix (:write opts) (or (:write-suffix opts) "!")))
-        bulk  (bulk-routes read write opts)]
-    (-> (routes read bulk write)
-        wrap-params
-        wrap-json)))
+  (let [{:keys [docs? write-suffix content-type]
+         :or {docs? true
+              write-suffix "!"
+              content-type "application/json; charset=utf-8"}
+         :as opts} (into-map opts)
+
+        suffix (or (:write-suffix opts) "!")
+        read   (read-routes  (ns-router ns-prefix (:read  opts)))
+        write  (write-routes (ns-router ns-prefix (:write opts) suffix))
+        bulk   (bulk-routes read write opts)
+        rs     (-> (routes read bulk write) wrap-params (wrap-content-type content-type))]
+    (routes
+     (when docs?
+       (doc-routes ns-prefix suffix))
+     rs)))

src/wakeful/docs.clj

@@ -0,0 +1,77 @@
+(ns wakeful.docs
+  (:use compojure.core
+        [hiccup core page-helpers]
+        [clojure.string :only [join]]))
+
+(defn extract-info
+  "Extract important information from the meta map of a var."
+  [x] (-> x meta (select-keys [:name :arglists :doc :ns])))
+
+(defn group-by-method
+  "Returns a map of :read and :write."
+  [ns suffix]
+  (->> ns symbol ns-publics keys
+       (group-by
+        #(if (.endsWith (name %) suffix)
+           :write
+           :read))))
+
+(defn generate-html
+  "Generate HTML based on some information from metadata."
+  [v ns-prefix]
+  (let [{:keys [arglists doc name ns]} v]
+    (html
+     [:a {:name name}]
+     [:h3 name]
+     [:p (str "/" (subs (str ns) (inc (count ns-prefix))) "/" name)]
+     (when arglists [:p (pr-str arglists)])
+     [:p doc])))
+
+(defn build-page
+  "Compose a documentation page."
+  [ns & components] (html4 [:body [:h1 ns] (apply str components)]))
+
+(defn generate-page
+  "Generate HTML documentation for all the public methods in a group of namespaces
+   under a prefix."
+  [ns-prefix ns suffix]
+  (let [{:keys [read write]} (group-by-method ns suffix)
+        gen #(-> % extract-info (generate-html ns-prefix))]
+    (build-page
+     ns
+     (html
+      [:h2 "Read"]
+      (map gen read)
+      [:h2 "Write"]
+      (map gen write)))))
+
+(defn anchor
+  "Creates anchors out of each of the items."
+  [ns items]
+  (join " "  (map #(html [:a {:href (str "/docs/" ns "#" %)} %]) items)))
+
+(defn extract-name
+  "Pull the name out of a var's metadata."
+  [v] (-> v meta :name))
+
+(defn generate-top
+  "Generate top-level page."
+  [ns-prefix suffix]
+  (let [nss (filter (partial re-find (-> ns-prefix str re-pattern))
+                    (map str (all-ns)))]
+    (html4
+     [:h1 "Namespaces under " ns-prefix]
+     [:head (include-css "/css/docs.css")]
+     [:body
+      (for [ns nss]
+        (html
+         [:a {:href (str "/docs/" ns)} ns]
+         [:br]
+         (let [{:keys [read write]} (group-by-method ns suffix)
+               name (partial map extract-name)]
+           (html
+            (str "Read: " (anchor ns (name read)))
+            [:br]
+            (str "Write: " (anchor ns (name write)))))
+         [:br]
+         [:br]))])))