Commits

Anonymous committed 77dac61

Added views and routing system to neman.web. Handling of view results is now similat to compojure. Imported examples for xml templates and json from old project and added some tests for web lib.

  • Participants
  • Parent commits ec2b216

Comments (0)

Files changed (7)

File examples/json1.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns user
+  (:require [net.ksojat.neman.json :as json]))
+
+(json/write-file "json1-1.json"
+  {:one   1
+   :two   "two"
+   :three [1 2 3]})
+
+(defstruct json-output
+  :first :second :third)
+
+(json/write-file "json1-2.json"
+  (struct-map json-output
+    :first  [1 2 {:a 1 :b 2}]
+    :second false
+    :third  {:a "b" :c "d"}))

File examples/xml1.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns user
+  (:require net.ksojat.neman.xml)
+  (:use net.ksojat.neman.core [net.ksojat.neman.xml :only [xml]])
+  (:import (org.jdom.output XMLOutputter)))
+
+(def html-doc
+  (xml
+    (=> :html
+      [(=> :head)
+       (=> :body
+         {:class "klass" :id "main"}
+         [(=> :p "Just some text.")])])))
+
+(.output (XMLOutputter.) html-doc System/out)

File examples/xml2.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns user
+  (:use net.ksojat.neman.core [net.ksojat.neman.xml :only [render template template-from cx child]])
+  (:import (org.jdom.output XMLOutputter)))
+
+(def base
+  (template
+    (=> :html
+      [(=> :head
+         [(=> :title [(cx :title)])])
+       (=> :body
+         [(=> :h1 [(cx :title)])
+          (child :body)
+          (=> :p [(cx :message)])
+          (child :extra)])])))
+
+(def level1
+  (template-from base
+    (:body
+      (=> :h2 "Second Header")
+      (for [i (range 5)]
+        (=> :p [(str "Generated " i)]))
+      (=> :div
+        [(child :body) (=> :p "Extra")]))
+    (:extra
+      (=> :div "ExtraDivTag"))))
+
+(def level2
+  (template-from level1
+    (:body
+      (=> :p "ExtraDva"))))
+
+(render level2 {:title "Naslov" :message "Poruka"})

File src/net/ksojat/neman/core.clj

   ([]         (UUID/randomUUID))
   ([uuid-str] (UUID/fromString uuid-str)))
 
-(defn throw-exception [& args]
-  (throw (Exception. (apply str args))))
+(defn throw-illegal-argument [& args]
+  (throw (IllegalArgumentException. (apply str args))))
 
 (defn throw-exception [& args]
   (throw (Exception. (apply str args))))

File src/net/ksojat/neman/jetty.clj

 (ns net.ksojat.neman.jetty
   (:use net.ksojat.neman.core)
   (:import
-    (org.mortbay.jetty Handler MimeTypes)
-    (org.mortbay.jetty.handler HandlerList HandlerCollection RewriteHandler)))
+    (javax.servlet.http HttpServletRequest HttpServletResponse)
+    (org.mortbay.jetty
+      Handler MimeTypes HttpConnection Request Response)
+    (org.mortbay.jetty.handler
+      AbstractHandler HandlerList HandlerCollection RewriteHandler)))
+
+;;
+;; Builder integration.
+;;
 
 (defmethod default-method [MimeTypes :vector] [& _] 'addMimeMappings)
 (defmethod default-method [RewriteHandler :vector] [& _] 'addRewriteRule)
   (.addHandler o
     (doto (HandlerCollection.) (.setHandlers (into-array-of Handler v)))))
 
+;;
+;; Helpers.
+;;
+
+(defn status [status-kw]
+  (kw-enum HttpServletResponse "SC" status-kw))
+
+(defn current-connection []
+  (HttpConnection/getCurrentConnection))
+
+(defn current-request []
+  (.getRequest (current-connection)))
+
+(defn get-request [r]
+  (if (instance? Request r) (cast Request r) (current-request)))
+
+(defn current-response []
+  (.getResponse (current-connection)))
+
+(defn get-response [r]
+  (if (instance? Response r) (cast Response r) (current-response)))
+
+(defn handler [f]
+  (proxy [AbstractHandler] []
+    (handle [target #^HttpServletRequest request #^HttpServletResponse response dispatch]
+      (let [request (get-request request), response (get-response response)]
+        (f target request response dispatch)))))

File src/net/ksojat/neman/web.clj

 
 (ns net.ksojat.neman.web
   (:refer-clojure :exclude [partial])
-  (:import
-    (javax.servlet.http HttpServletRequest HttpServletResponse Cookie)
-    (org.mortbay.jetty HttpConnection Handler Request Response)
-    (org.mortbay.jetty.handler AbstractHandler))
-  (:use net.ksojat.neman.core))
-
-(defmacro defexception [name]
-  `(gen-class :name ~name :extends Exception))
-
-(defexception net.ksojat.neman.web.InvalidRule)
-(defexception net.ksojat.neman.web.UnknownConvertor)
-;(gen-class :name net.ksojat.neman.web.InvalidRule :extends Exception)
-;(gen-class :name net.ksojat.neman.web.UnknownConvertor :ectends Exception)
-
-;(import
-;  '(net.ksojat.neman.web InvalidRule UnknownConvertor))
+  (:require [net.ksojat.neman.jetty :as jetty])
+  (:use clojure.set net.ksojat.neman.core))
 
 ;;
 ;; URL path convertors.
 (defmulti convertor (fn [name] name))
 
 (defmethod convertor :default [name]
-  (throw
-    (Exception. (str "Unknown convertor for type: " (prn name)))))
+  (throw-exception "Unknown convertor for tyoe: " name))
 
 (defmethod convertor :kw [_]
-  {:regex    "([^\\\\]+)"
+  {:regex    "([^/]+)"
    :from-url keyword
    :to-url   name})
 
    :to-url   #(Integer/toString %)})
 
 (defmethod convertor :str [_]
-  {:regex    "([^\\\\]+)"
+  {:regex    "([^/]+)"
    :from-url (fn [v] v)
    :to-url   (fn [v] v)})
 
    :from-url uuid
    :to-url   str})
 
-; TODO: date and date-map convertors
+(defmethod convertor :date [_]
+  {:regex    "([0-9]{8})"
+   :from-url (fn [v] v)
+   :to-url   (fn [v] v)})
+
+(defmethod convertor :date-map [_]
+  {:regex    "([0-9]{8})"
+   :from-url (fn [v]
+               (let [[_ year month day] (re-matches #"([0-9]{4})([0-9]{2})([0-9]{2})" v)]
+                 {:year year :month month :day day}))
+   :to-url   (fn [{:keys [year month day]}] (str year month day))})
 
 (defn convertor-regex [type]
-  (when type
-    (:regex (convertor type))))
+  (:regex (convertor type)))
 
 (defn from-url [type value]
-  (when type
-    (((convertor type) :from-url) value)))
+  (((convertor type) :from-url) value))
 
 (defn to-url [type value]
-  (when type
-    (((convertor type) :to-url) value)))
+  (((convertor type) :to-url) value))
 
 ;;
 ;; Views.
 ;;
 
+(defn new-arg [name type value]
+  {:name name :type type :value value})
+
+(defn value? [arg]
+  (= (:type arg) :value))
+
+(defn convertor? [arg]
+  (= (:type arg) :convertor))
+
+(defn distinct-arguments?
+  "Check are view argument names unique."
+  [arg-seq]
+  (or (not (seq? arg-seq)) (apply distinct? (map :name arg-seq))))
+
 (defmacro view [bindings & body]
   (let [expand   (fn
-                   ([s]     [s [s [:convertor :str]]])
-                   ([s c]   [s [s [:convertor c]]])
-                   ([d s c] [d [s [:convertor c]]]))
+                   ([s]     [s (new-arg s :convertor :str)])
+                   ([s c]   [s (new-arg s :convertor c)])
+                   ([d s c] [d (new-arg s :convertor c)]))
         bindings (map #(apply expand (if (vector? %) % (list %))) bindings)
-        vargs (map (fn [[_ v]] v) bindings)
-        fargs (map (fn [[f _]] f) bindings)]
-    `(with-meta
-       {:args '~(vec vargs)
-        :view (fn ~(vec fargs) ~@body)}
-       {::view true})))
+        fargs (map first  bindings)
+        vargs (map second bindings)]
+    (println vargs) (println fargs)
+    (if (distinct-arguments? vargs)
+      `(with-meta
+         {:args '~(vec vargs), :fn (fn ~(vec fargs) ~@body)}
+         {::view true})
+      (throw-illegal-argument "View arguments must have unique names."))))
+
+(defmacro defview [name bindings & body]
+  `(def ~name (view ~bindings ~@body)))
 
 (defn view? [x]
   (true? (::view (meta x))))
 
-(defn value? [x]
-  (= :value x))
-
-(defn convertor? [x]
-  (= :convertor x))
-
 (defn argument-names [view]
-  (filter #(not= % nil)
-    (map (fn [[k [t _]]] (if (not (value? t)) k)) (view :args))))
+  (map :name (filter convertor? (view :args))))
 
 (defn argument-types [view]
   (into {}
-    (filter #(not= nil %)
-      (map (fn [[n [t x]]] (if (convertor? t) [n x])) (view :args)))))
+    (map (fn [a] [(:name a) (:value a)]) (filter convertor? (view :args)))))
 
 (defn argument-regex [view]
   (into {}
-    (map (fn [[k v]] [(name k) (convertor-regex v)]) (argument-types view))))
+    (map (fn [[name type]] [name (convertor-regex type)]) (argument-types view))))
 
 (defn call-view [view arguments]
-  (apply (view :view)
+  (let [[n1 n2] [(set (argument-names view)) (set (keys arguments))]
+        [d1 d2] [(difference n1 n2) (difference n2 n1)]]
+    (cond
+      (not= #{} d1) (throw-illegal-argument "Missing argument(s): " d1)
+      (not= #{} d2) (throw-illegal-argument "Unknown argument(s): " d2)
+      :else
+        (apply (view :fn)
+          (map
+            (fn [a]
+              (if (value? a)
+                (:value a) (from-url (:value a) (arguments (:name a)))))
+            (view :args))))))
+
+(defn has-argument? [view name]
+  (some #(= name %) (argument-names view)))
+
+(defn update-arguments [view new-arg]
+  (if (false? (has-argument? view (:name new-arg)))
+    (throw-illegal-argument "Unknown argument: " (:name new-arg)))
+  (assoc view :args
     (map
-      (fn [[k [type x]]]
-        (if (= type :value)
-          x
-          (if (contains? arguments k)
-            (from-url x (arguments k))
-            (throw (Exception. "xxxx")))))
+      (fn [old-arg]
+        (if (= (:name new-arg) (:name old-arg)) new-arg old-arg))
       (view :args))))
 
-(defmacro defview [name bindings & body]
-  `(def ~name (view ~bindings ~@body)))
+(defn partial [view new-args]
+  (let [update (apply comp
+                 (map
+                   (fn [[k v]] #(update-arguments % (new-arg k :value v)))
+                  new-args))]
+    (update view)))
 
-(defn partial [view new-args] ; TODO
-  (let [update (fn [args [new-k _ :as new-row]]
-                 (map
-                   (fn [[old-k [type _] :as old-row]]
-                     (if (= new-k old-k)
-                       (if (= type :value) (throw (Exception. "kkk")) new-row)
-                       old-row))
-                   args))]
-    (loop [new-args (map (fn [[k v]] [k [:value v]]) new-args)
-           old-args (view :args)]
-      (if (seq new-args)
-        (let [x (update old-args (first new-args))]
-          (if (= x old-args)
-            (throw (Exception. "beep"))
-            (recur (rest new-args) x)))
-        (assoc view :args (vec old-args))))))
+;;
+;; Paths.
+;;
+
+(defn get-view-at [paths view-path]
+  (let [x (get-in paths view-path)] (if (view? x) x)))
+
+;;
+;; Rules.
+;;
+
+(def rule-pattern #"(?:([^<]*)(?:<([^>]*)>))|([^<^>]*)")
+
+(defn rule-part-seq [route]
+  (butlast (re-seq rule-pattern route)))
+
+(defn valid-rule-part? [rule]
+  (not= ["" nil nil ""] rule))
+
+(defn parse-rule [rule]
+  (let [ps (rule-part-seq rule)] (if (every? valid-rule-part? ps) ps)))
+
+(defn rule-parts [rule]
+  (map (fn [[_ path1 arg path2]] [(or path1 path2) arg]) (parse-rule rule)))
+
+(defn valid-rule? [rule-parts]
+  (not= nil rule-parts))
+
+(defn rule-names [rule]
+  (filter not-nil?
+    (map (fn [[_ name]] name) (rule-parts rule))))
+
+(defn rule-regex [rule arg-regex]
+  (loop [parts (rule-parts rule), out []]
+    (if (seq parts)
+      (let [[[path arg] & ps] parts]
+        (recur ps (conj out path (arg-regex (if arg (symbol arg))))))
+      (re-pattern (apply str out)))))
+
+;(defn rule-regex [rule arg-regex]
+;  (loop [parts (rule-parts rule), out []]
+;    (if-let [[[path arg] & ps] parts]
+;      (recur ps (conj out path (arg-regex (symbol arg))))
+;      (re-pattern (apply str out)))))
+
+;(defn rule-regex [rule arg-regex]
+;  (loop [[[path arg] & ps] (rule-parts rule), out []]
+;    (if (seq ps)
+;      (recur ps (conj out path (arg-regex (symbol arg))))
+;      (re-pattern (apply str out)))))
+
+(defn rule-matcher [rule arg-regex]
+  (let [regex (rule-regex rule arg-regex)
+        names (map symbol (rule-names rule))]
+    (fn [url-path]
+      (when-let [[_ & args] (re-matches regex url-path)]
+        (apply hash-map (interleave names args))))))
 
 ;;
 ;; Routes.
 ;;
 
-(def rule-pattern #"(?:([^<]*)(?:<([^>]*)>))|([^<^>]*)")
+(defn route [rule path view]
+  [(rule-matcher rule (argument-regex view)) path view])
 
-(defn rule-seq [route]
-  (butlast (re-seq rule-pattern route)))
+(defn create-routes [paths rules]
+  (map
+    (fn [[path rule]]
+      (let [view (get-view-at paths path)]
+        (if view
+          (route rule path view)
+          (throw-exception "Unknown view at: " path))))
+    rules))
 
-(defn valid-rule? [rule]
-  (not= ["" nil nil ""] rule))
+(defn create-default-routes
+  "Create default routes from path names."; TODO: Write more docs here
+  ([paths]
+    (create-default-routes paths {}))
 
-(defn parse-route [route]
-  (let [ps (rule-seq route)] (if (every? valid-rule? ps) ps)))
+  ([paths exceptions]
+    nil)); TODO: Add code for this
 
-(defn route-parts [route]
-  (map (fn [[_ path1 arg path2]] [(or path1 path2) arg]) (parse-route route)))
-
-(defn valid-route? [route-parts]
-  (not= nil route-parts))
-
-(defn route-names [route]
-  (filter #(not= nil %)
-    (map (fn [[_ name]] name) (route-parts route))))
-
-(defn route-regex [route arg-regex]
-  (loop [parts (route-parts route), out []]
-    (if (seq parts)
-      (let [[[path arg] & ps] parts]
-        (recur ps (conj out path (arg-regex arg))))
-      (re-pattern (apply str out)))))
-
-(defn route-matcher [route arg-regex]
-  (fn [url-path]
-    (rest (re-matches (route-regex route arg-regex) url-path))))
-
-(defn route-arguments [names arguments]
-  (apply hash-map (interleave names arguments)))
 
 ;;
 ;; Jetty integration.
 ;;
 
-(defn status [status-kw]
-  (kw-enum HttpServletResponse "SC" status-kw))
+(def status
+  #(jetty/status %))
 
-(defn current-connection []
-  (HttpConnection/getCurrentConnection))
+(defmulti update-response (fn [response x] (class x)))
 
-(defn current-request []
-  (.getRequest (current-connection)))
+(defmethod update-response String [response x]
+  (.. response getWriter (print x)))
 
-(defn get-request [r]
-  (if (instance? Request r) (cast Request r) (current-request)))
+(defmethod update-response clojure.lang.IPersistentMap [response x]
+  (doseq [k (keys x)] (.setHeader response k (x k))))
 
-(defn current-response []
-  (.getResponse (current-connection)))
+(defmethod update-response clojure.lang.Keyword [response x]
+  (.setStatus response (status x)))
 
-(defn get-response [r]
-  (if (instance? Response r) (cast Response r) (current-response)))
+(defmethod update-response javax.servlet.http.Cookie [response x]
+  (.addCookie response x))
 
-(defn mapper [paths routes]
-  (proxy [AbstractHandler] []
-    (handle [target #^HttpServletRequest request #^HttpServletResponse response dispatch]
-      (let [request (get-request request), response (get-response response)]
-        (.setHandled request true)
-        (.setStatus  response (status :ok))
-        (.. response getWriter (println "hi"))))))
+(defmethod update-response java.io.File [response x]
+  ; TODO
+)
+
+(def url-for)
+(def redirect-to)
+
+(declare
+  *request* *response*)
+
+(defn handle-url [url-path [[matcher path view] & rs]]
+  (if-let [args (matcher url-path)]
+    (when-let [res (call-view view args)]
+      (.setHandled *request* true)
+      (.setStatus  *response* (status :ok))
+      (if (vector? res)
+        (doseq [r res] (update-response *response* r))
+        (update-response *response* res))))
+    (when (seq rs) (recur url-path rs))))
+
+(defn mapper [paths rules]
+  (let [routes (create-routes paths rules)]
+    (jetty/handler
+      (fn [target request response dispatch]
+        (binding [*request* request, *response* response]
+          (handle-url target routes))))))

File tests/test.clj

     (net.ksojat.neman [web :as web]))
   (:use clojure.contrib.test-is))
 
-(deftest neman-web-route-parsing
+(deftest web-convertor
+  (is (thrown? Exception (web/convertor :default))))
+
+(deftest web-is-view
+  (let [v (web/view [] "test view")]
+    (are (= _1 _2)
+      (web/view? v)  true
+      (web/view? {}) false)))
+
+(deftest web-call-view
+  (let [v (web/view [a b] "test view")]
+    (are (thrown? _1 _2)
+      Exception (web/call-view v {'a 1})))
+  (let [v (web/partial (web/view [x] "test view") {'x 100})]
+    (is (thrown? Exception (web/call-view v {'x 200})))))
+
+(deftest web-partial-view
+  (let [v0 (web/view [a] "test view")
+        v1 (web/partial v0 {'a 100})]
+    (is (thrown? Exception (web/partial v1 {'a 200}))
+    (is (thrown? Exception (web/partial v1 {'b 100}))))))
+
+(deftest web-rule-parsing
   (are (= _1 _2)
-    (web/route-parts "/index/<name>") '(["/index/" "name"])
-    (web/route-parts "/show-page")    '(["/show-page" nil])
-    (web/route-parts "<name>")        '(["" "name"])
-    (web/route-parts "<name")         nil
-    (web/route-parts "name>")         nil))
+    (web/rule-parts "/index/<name>") '(["/index/" "name"])
+    (web/rule-parts "/show-page")    '(["/show-page" nil])
+    (web/rule-parts "<name>")        '(["" "name"])
+    (web/rule-parts "<name")         nil
+    (web/rule-parts "name>")         nil))
+
+(deftest web-rule-regex
+  (are (= _1 _2)
+    (web/rule-regex "/login" {}) #"/login"))
+
+(deftest web-rule-names
+  (are (= _1 _2)
+    ('a 'b) (web/rule-names "<a><b>")
+    '()     (web/rule-names "/show")
+    '()     (web/rule-names "")))
 
 (run-all-tests)