Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added some neat features

  • Loading branch information...
commit 8f27a064da47874ed0c76a6239bb62d200c773a8 1 parent 21663f6
@zefhemel authored
View
11 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
View
6 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"]])
View
57 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)))))
View
8 src/adia/form.clj
@@ -0,0 +1,8 @@
+(ns adia.form
+ (:gen-class))
+
+
+(defn field-row [label input]
+ [:tr
+ [:td label]
+ [:td input]])
View
145 src/adia/model.clj
@@ -1,41 +1,57 @@
(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)
@@ -43,40 +59,95 @@
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))))
View
44 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)
View
19 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)))
View
74 src/clojure/stacktrace.clj
@@ -0,0 +1,74 @@
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html 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.
+
+;;; stacktrace.clj: print Clojure-centric stack traces
+
+;; by Stuart Sierra
+;; January 6, 2009
+
+(ns
+ #^{:author "Stuart Sierra",
+ :doc "Print Clojure-centric stack traces"}
+ clojure.stacktrace)
+
+(defn root-cause
+ "Returns the last 'cause' Throwable in a chain of Throwables."
+ [tr]
+ (if-let [cause (.getCause tr)]
+ (recur cause)
+ tr))
+
+(defn print-trace-element
+ "Prints a Clojure-oriented view of one element in a stack trace."
+ [e]
+ (let [class (.getClassName e)
+ method (.getMethodName e)]
+ (let [match (re-matches #"^([A-Za-z0-9_.-]+)\$(\w+)__\d+$" class)]
+ (if (and match (= "invoke" method))
+ (apply printf "%s/%s" (rest match))
+ (printf "%s.%s" class method))))
+ (printf " (%s:%d)" (or (.getFileName e) "") (.getLineNumber e)))
+
+(defn print-throwable
+ "Prints the class and message of a Throwable."
+ [tr]
+ (printf "%s: %s" (.getName (class tr)) (.getMessage tr)))
+
+(defn print-stack-trace
+ "Prints a Clojure-oriented stack trace of tr, a Throwable.
+ Prints a maximum of n stack frames (default: unlimited).
+ Does not print chained exceptions (causes)."
+ ([tr] (print-stack-trace tr nil))
+ ([tr n]
+ (let [st (.getStackTrace tr)]
+ (print-throwable tr)
+ (newline)
+ (print " at ")
+ (print-trace-element (first st))
+ (newline)
+ (doseq [e (if (nil? n)
+ (rest st)
+ (take (dec n) (rest st)))]
+ (print " ")
+ (print-trace-element e)
+ (newline)))))
+
+(defn print-cause-trace
+ "Like print-stack-trace but prints chained exceptions (causes)."
+ ([tr] (print-cause-trace tr nil))
+ ([tr n]
+ (print-stack-trace tr n)
+ (when-let [cause (.getCause tr)]
+ (print "Caused by: " )
+ (recur cause n))))
+
+(defn e
+ "REPL utility. Prints a brief stack trace for the root cause of the
+ most recent exception."
+ []
+ (print-stack-trace (root-cause *e) 8))
Please sign in to comment.
Something went wrong with that request. Please try again.