Added some neat features

open-vim

@@ -0,0 +1,11 @@
+#!/bin/bash
+
+cd src
+
+java -cp $CLASSPATH:/zef/hg/vimclojure/build/vimclojure.jar com.martiansoftware.nailgun.NGServer 127.0.0.1 &
+
+echo $?
+
+sleep 2
+
+mvim */*.clj

project.clj

@@ -0,0 +1,6 @@
+(defproject adia "0.1-SNAPSHOT"
+            :description "A Clojure web framework"
+            :url "http://github.com/zefhemel/adia"
+            :dependencies [[org.clojure/clojure "1.0.0"]
+                           [org.clojure/clojure-contrib "1.0-SNAPSHOT"]
+                           [org.clojars.ato/compojure "0.3.1"]])

src/adia/controller.clj

@@ -1,5 +1,6 @@
 (ns adia.controller
   (:use compojure)
+  (:use adia.util)
   (:use [adia.model :as model]))
 
 (def *uri-mapping* (ref {}))
@@ -8,19 +9,7 @@
 (def *request* nil)
 (def *form* nil)
 
-(defn even-items [lst]
-  (loop [evens []
-         r     lst]
-    (if (< (count r) 2)
-      evens
-      (recur (conj evens (first r)) (rest (rest r))))))
-
-(defn odd-items [lst]
-  (loop [odds []
-         r     lst]
-    (if (< (count r) 2)
-      odds
-      (recur (conj odds (second r)) (rest (rest r))))))
+(def *message* nil)
 
 (defn convert-type [val type]
   (cond
@@ -34,7 +23,33 @@
                                       :value (*form* name))])
   ([name] (input-string {} name)))
 
-(defmacro defact
+(defn input-password 
+  ([attrs name] [:input (assoc attrs 
+                               :type "password"
+                               :name name
+                               :value (*form* name))])
+  ([name] (input-password {} name)))
+
+(defn input-text 
+  ([attrs name] [:textarea (assoc attrs :name name
+                                      (*form* name))])
+  ([name] (input-text {} name)))
+
+(defn form [webfn & body]
+  (form-to [:post (:uri webfn)]
+           body))
+
+(defn render [webfn & args]
+  (if (= (first args) :flash)
+    (binding [*message* (second args)]
+      (apply (:fn webfn) (rest (rest args))))
+    (apply (:fn webfn) args)))
+
+(defn redirect [webfn & args]
+  {:status 302
+   :headers {"Location" (:uri webfn)}})
+
+(defmacro defwebfn
   ([name doc-str attrs args body]
    (let [controller-parts (.split (str (ns-name *ns*)) "\\.")
          controller-name  (aget controller-parts (- (alength controller-parts) 1))
@@ -50,6 +65,7 @@
                                         (str "/" action-name)))))]
      `(do
         (def ~name {:name      (str (quote ~name))
+                    :uri       (str "/" ~uri)
                     :arg-names (quote ~(even-items args))
                     :arg-types (quote ~(odd-items args))
                     :doc       ~doc-str
@@ -60,6 +76,13 @@
           (commute *uri-mapping* assoc ~uri ~name)))))
   ([name doc-or-attrs args body] 
     (if (string? doc-or-attrs) ; doc
-     `(defact ~name ~doc-or-attrs {} ~args ~body)
-     `(defact ~name nil ~doc-or-attrs ~args ~body)))
-  ([name args body] `(defact ~name nil {} ~args ~body)))
+     `(defwebfn ~name ~doc-or-attrs {} ~args ~body)
+     `(defwebfn ~name nil ~doc-or-attrs ~args ~body)))
+  ([name args body] `(defwebfn ~name nil {} ~args ~body)))
+
+
+(defmacro on-error [webfn & body]
+  `(try
+     ~@body
+     (catch RuntimeException e#
+       (render ~webfn :flash (.. e# getCause getMessage)))))

src/adia/form.clj

@@ -0,0 +1,8 @@
+(ns adia.form
+  (:gen-class))
+
+
+(defn field-row [label input]
+  [:tr
+   [:td label]
+   [:td input]])

src/adia/model.clj

@@ -1,82 +1,153 @@
 (ns adia.model
   (:use [clojure.contrib.sql :as sql])
+  (:use adia.util)
   (:gen-class))
 
 (def *db-config* (ref {}))
 
-(def fk-type "varchar(64)")
+(def *db-entites* (ref {}))
+
+(defmacro with-conn [& body]
+  `(sql/with-connection
+     @*db-config*
+     (sql/transaction
+       ~@body)))
 
 (defn- query [query]
   (with-query-results 
     rs query
     (doall rs)))
 
-(defn- kind->table
-  [kind]
-  (.substring (str kind) 1))
-
 (defn- keyword->str
   [kw]
   (.substring (str kw) 1))
 
-(defn create-entity-type
-  [kind & columns]
-  (apply sql/create-table
-         kind
-         [:id "varchar(64)" "PRIMARY KEY"]
-         columns))
-
-(defn entity 
-  "Create a new entity instance of the supplied kind"
-  [kind & kvs]
-  (with-meta
-    (apply assoc {:kind kind
-                  :id (str (java.util.UUID/randomUUID))}
-           kvs)
-    {:persisted false}))
-
-(defn persist
+(defn col-def-to-sql [[name & col-def]]
+  (condp = (first col-def)
+    :string (if (= (count col-def) 2)
+              (let [attrs (second col-def)]
+                [name (str "VARCHAR(" 
+                           (if (:length attrs)
+                             (:length attrs)
+                             "255")
+                           ")")
+                 (if (:unique (second col-def))
+                   "UNIQUE"
+                   "")])
+              [name "VARCHAR(255)"])
+    :int      [name "INT"]
+    :password [name "VARCHAR(62)"]
+    :email    [name "VARCHAR(80)"]
+    :text     [name "MEDIUMTEXT"]
+    ; else, entity reference
+    [name "VARCHAR(36)"]))
+
+(defn sync-database-metadata [name]
+  (with-conn
+    (let [all-tables (mapcat vals (query ["SHOW TABLES"]))]
+      (if-not (some #(= %1 (str name)) all-tables)
+        (apply sql/create-table
+               (keyword (str name))
+               [:id "varchar(64)" "PRIMARY KEY"]
+               (map col-def-to-sql ((*db-entites* name) :properties)))))))
+
+(defn persist!
   "Persists a given entity to the database"
   [ent]
   (let [kind       (:kind ent)
         clean-ent  (dissoc ent :kind)
         persisted  (:persisted ^ent)]
     (if persisted
       (sql/update-values
-        kind
+        (kind :tblname)
         ["id = ?" (:id ent)]
         (dissoc clean-ent :id))
       (sql/insert-values
-        kind (keys clean-ent) (vals clean-ent))))
+        (kind :tblname)
+        (keys clean-ent) (vals clean-ent))))
   (println "Persisted it!")
   (with-meta ent {:persisted true}))
 
 (defn retrieve
   "Retrieves an entity from the database"
   [kind id]
-  (if-let [rs (query [(str "select * from " (kind->table kind) " where id = ?") id])]
+  (if-let [rs (query [(str "select * from " (kind :tblname) " where id = ?") id])]
     (first rs)
     nil))
 
-(defn find-by [kind prop value]
-  (if-let [rs (query [(str "select * from " (kind->table kind) " where `" prop "` = ?") value])]
-    (first rs)
-    nil))
+(defn find-all-by [kind & prop-value-pairs]
+  (query (apply vector 
+                (str "select * from " (kind :tblname) " where "
+                     (reduce #(str %1 " AND " %2)
+                             (map #(str "`" (keyword->str %1) "` = ?") (even-items prop-value-pairs))))
+                (odd-items prop-value-pairs))))
 
-(defn find-all-by [kind prop value]
-  (query [(str "select * from " (kind->table kind) " where `" (keyword->str prop) "` = ?") value]))
+(defn find-by [kind & prop-value-pairs]
+  (if-let [results (apply find-all-by kind prop-value-pairs)]
+    (first results)
+    nil))
 
 (defn retrieve-all
   "Retrieves an entity from the database"
   [kind]
-  (query [(str "select * from " (kind->table kind))]))
+  (query [(str "select * from " (kind :tblname))]))
 
 (defn set-db-config! [config]
   (dosync
     (ref-set *db-config* config)))
 
-(defmacro with-conn [& body]
-  `(sql/with-connection
-     @*db-config*
-     (sql/transaction
-       ~@body)))
+(defn- bind-property [ent value spec]
+  (let [column-type (second spec)]
+    (condp = column-type
+      :string  (if (= (count spec) 3)
+                 (let [attrs (nth spec 2)]
+                   (if (and (:length attrs)
+                            (> (count value) (:length attrs)))
+                     (throw (RuntimeException. (str "Value '" value "' is too, long, maximum length: " (:length attrs)))))
+                   (if (:unique attrs)
+                     (if-let [duplicate (find-by (:kind ent) (first spec) value)]
+                       (if-not (= (:id ent) (:id duplicate))
+                         (throw (RuntimeException. (str "Value '" value "' is not unique."))))))
+                   value)
+                 value)
+      :int      (try
+                  (Integer/parseInt value)
+                  (catch NumberFormatException nfe (RuntimeException. (str "Value '" value "' is not a number."))))
+      :password (md5 value)
+      :text      value
+      :email    (if (re-matches #".+@.+\.[a-z]+" value)
+                  value
+                  (throw (RuntimeException. (str "'" value "' is not a valid e-mail address."))))
+      ; entity type
+      value ; for now, no checking
+      )))
+
+(defn- lookup-property [kind property-name]
+  (let [properties (filter #(= (first %1) property-name) (kind :properties))]
+    (if (empty? properties)
+      nil
+      (first properties))))
+
+(defn databind 
+  ([ent values-map selected-properties] 
+   (apply assoc ent 
+          (mapcat (fn [k] [k (bind-property ent (values-map k) (lookup-property (:kind ent) k))])
+                  selected-properties)))
+  ([ent values-map] (databind ent values-map (keys values-map))))
+
+(defmacro defent [name & properties]
+  `(do
+     (defn ~name
+       ([] (with-meta {:kind ~name
+                       :id (str (java.util.UUID/randomUUID))}
+                      {:persisted false}))
+       ([key#] ({:tblname    (str (quote ~name))
+                 :properties [~@properties]} key#))
+       ([k# v# & kvs# ] (with-meta
+                          (apply assoc {:kind ~name
+                                        :id (str (java.util.UUID/randomUUID))}
+                                 k# v# kvs#)
+                          {:persisted false})))
+     (dosync 
+       (commute *db-entites* assoc (quote ~name) ~name))
+     (sync-database-metadata (quote ~name))))

src/adia/servlet.clj

@@ -1,4 +1,5 @@
 (ns adia.servlet
+  (:use clojure.stacktrace)
   (:use compojure)
   (:use [clojure.contrib.sql :as sql])
   (:use adia.model)
@@ -19,21 +20,38 @@
                                          (find-prefix-match (rest coll) uri))))
     :else (find-prefix-match (rest coll) uri)))
 
+(defn handler [request]
+  (let [uri             (.substring (:uri request) 1)
+        controller-name (find-prefix-match @*uri-list* uri)
+        uri-parts       (if controller-name
+                          (if (= controller-name uri) ; no params
+                            ()
+                            (.split (.substring uri (+ (.length controller-name) 1)) "/")))
+        controller      (if controller-name (@*uri-mapping* controller-name))
+        args            (if controller-name (map convert-type uri-parts (:arg-types controller)))]
+    (if controller
+      (let [result (binding [*request*  request
+                             *form*     (:form-params request)]
+                     (with-conn (apply (:fn controller) args)))]
+        (if (string? result)
+          {:status 200
+           :headers {}
+           :body result}
+          result)))))
+
+(decorate handler (with-session :memory))
+
 (defroutes 
   webservice
   (ANY "/*"
-       (let [uri             (.substring (:uri request) 1)
-             controller-name (find-prefix-match @*uri-list* uri)
-             uri-parts       (if controller-name
-                               (if (= controller-name uri) ; no params
-                                 ()
-                                 (.split (.substring uri (+ (.length controller-name) 1)) "/")))
-             controller      (if controller-name (@*uri-mapping* controller-name))
-             args            (if controller-name (map convert-type uri-parts (:arg-types controller)))]
-         (if controller
-           (binding [*request*  request
-                     *form*     (:form-params request)]
-             (with-conn (apply (:fn controller) args)))
-           (or (serve-file (params :*)) (page-not-found))))))
+       (or 
+         (try
+           (handler request)
+           (catch Throwable e
+             (print-stack-trace e)
+             (println)
+             "Internal server error"))
+         (serve-file (params :*)) 
+         (page-not-found))))
 
 (defservice webservice)

src/adia/util.clj

@@ -1,6 +1,20 @@
 (ns adia.util
   (:use [clojure.contrib.duck-streams :only (slurp*)]))
 
+(defn even-items [lst]
+  (loop [evens []
+         r     lst]
+    (if (< (count r) 2)
+      evens
+      (recur (conj evens (first r)) (rest (rest r))))))
+
+(defn odd-items [lst]
+  (loop [odds []
+         r     lst]
+    (if (< (count r) 2)
+      odds
+      (recur (conj odds (second r)) (rest (rest r))))))
+
 (defn- silent-read
   [s]
   (try
@@ -25,3 +39,8 @@
 (defmacro <<
   [string]
   `(str ~@(interpolate string)))
+
+(defn md5 [str]
+  (let [md (java.security.MessageDigest/getInstance "MD5")]
+    (.update md (.getBytes str))
+    (.toString (BigInteger. 1 (.digest md)) 16)))