diff --git a/.gitignore b/.gitignore index ffc495c..998d543 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ -target *~ \#*# +classes +lib/ diff --git a/pom.xml b/pom.xml deleted file mode 100644 index 05320be..0000000 --- a/pom.xml +++ /dev/null @@ -1,106 +0,0 @@ - - 4.0.0 - de.fnogol - compojure-rest - 0.1-SNAPSHOT - - - - org.clojure - clojure - 1.0.0 - - - org.clojure - clojure-contrib - 1.0-SNAPSHOT - - - org.compojure - compojure - 0.3.1-SNAPSHOT - - - org.mortbay.jetty - jetty - 6.1.21 - - - commons-codec - commons-codec - 1.4 - - - commons-fileupload - commons-fileupload - 1.2.1 - - - commons-io - commons-io - 1.4 - - - - - - - - - - jline - jline - 0.9.94 - - - com.codestuffs.clojure - swank-clojure - 1.0-SNAPSHOT - - - - - - com.theoryinpractise - clojure-maven-plugin - - - - - compile-clojure - compile - - compile - - - - - - - - diff --git a/project.clj b/project.clj new file mode 100644 index 0000000..b0d3b38 --- /dev/null +++ b/project.clj @@ -0,0 +1,11 @@ +(defproject compojure-rest "0.0.1-SNAPSHOT" + :dependencies [[org.clojure/clojure "1.1.0-alpha-SNAPSHOT"] + [org.clojure/clojure-contrib "1.0-SNAPSHOT"] + [org.clojars.ato/compojure "0.3.1"] + [org.mortbay.jetty/jetty "6.1.21"] + [commons-codec/commons-codec "1.4"] + [commons-fileupload/commons-fileupload "1.2.1"] + [commons-io/commons-io "1.4"] + ] + :dev-dependencies [[org.clojure/swank-clojure "1.0"] + [lein-clojars "0.5.0-SNAPSHOT"]]) diff --git a/src/main/clojure/compojure_rest.clj b/src/compojure_rest.clj similarity index 86% rename from src/main/clojure/compojure_rest.clj rename to src/compojure_rest.clj index 07c50c2..e77a719 100644 --- a/src/main/clojure/compojure_rest.clj +++ b/src/compojure_rest.clj @@ -11,6 +11,7 @@ (:use compojure.http.response) (:use clojure.contrib.core) (:import java.util.Date) + (:import java.util.TimeZone) (:import java.lang.System) (:import java.util.Locale) (:import java.text.SimpleDateFormat)) @@ -20,16 +21,26 @@ (function-or-value request) function-or-value)) -(def *http-date-format* - (new SimpleDateFormat - "EEE, dd MMM yyyy HH:mm:ss Z" - Locale/US)) +(def *http-date-format* "EEE, dd MMM yyyy HH:mm:ss Z") -(defn http-date [int-or-date] - (if-let [date (if (integer? int-or-date) - (new Date (+ int-or-date (System/currentTimeMillis))) - int-or-date)] - (.format *http-date-format* date))) +(defmulti -get-timezone (fn [x] (type x))) +(defmethod -get-timezone String [tz] (TimeZone/getTimeZone tz)) +(defmethod -get-timezone TimeZone [tz] tz) + +(defn http-date-format + ([] (http-date-format (TimeZone/getDefault))) + ([tz] (let [df (new SimpleDateFormat + *http-date-format* + Locale/US)] + (do (.setTimeZone df (-get-timezone tz)) + df)))) + +(defn relative-date [int] + (new Date (+ int (System/currentTimeMillis)))) + +(defn http-date + ([date] (.format (http-date-format) date)) + ([date timezone] (.format (http-date-format timezone) date))) (defn wrap-header [handler header generate-header] (fn [request] diff --git a/src/compojure_rest/resource.clj b/src/compojure_rest/resource.clj new file mode 100644 index 0000000..40a10e1 --- /dev/null +++ b/src/compojure_rest/resource.clj @@ -0,0 +1,214 @@ +;; Copyright (c) Philipp Meier (meier@fnogol.de). 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. + +(ns compojure-rest.resource + (:use compojure) + (:use compojure.http.response) + (:use compojure-rest) + (:use clojure.contrib.core) + (:use clojure.contrib.trace) + (:import clojure.lang.Fn) + (:import java.util.Date) + (:import java.util.Map) + (:import java.lang.System) + (:import java.util.Locale) + (:import java.text.SimpleDateFormat)) + + +(def *default-functions* + { + :service-available true + :uri-too-long false + :known-method (fn [req] (#(some #{(:request-method req)} + [:get :head :options + :put :post :delete :trace]))) + :method-allowed (fn [req] (#(some #{(:request-method req)} + [:get :head]))) + :malformed false + :authorized true + :allowed true + :known-content-type true + :valid-content-header true + :valid-entity-length true + :options {} + :content-types-provided "text/html" + :languages-provided "*" + :encodings-provided "*" + :charsets-provided "*" + :get "" + :exists true + }) + +(defn simple-negotiate [provided accept-header] + (let [provided-l (if (coll? provided) provided [provided]) ] + (if (or (.contains accept-header "*/*") + (= accept-header "*")) + (first provided-l) + (if (some #{"*"} provided-l) + accept-header + (#(some #{accept-header} provided-l)))))) + +(defn wrap-options [handler generate-options-header] + (fn [request] + (if (= :options (request :request-method)) + { :headers (evaluate-generate generate-options-header request)} + (handler request)))) + +(defn wrap-accept-header [handler provider-function negotiate-function header neg-key default] + (fn [request] + (let [accept ((request :headers {}) header default) + provided (evaluate-generate provider-function request)] + (if-let [neg (negotiate-function provided accept)] + (handler (assoc-in request [::rest neg-key] neg)) + {:statuc 406 :body (str header " " accept " cannot be provided. Available is " provided)})) + )) + +(defn wrap-accept [handler content-types-provided] + (wrap-accept-header handler content-types-provided simple-negotiate + "Accept" :neg-content-type "*/*")) + +(defn wrap-accept-language [handler provider-function] + (wrap-accept-header handler provider-function simple-negotiate + "Accept-Language" :neg-lang "*")) + +(defn wrap-accept-charset [handler provider-function] + (wrap-accept-header handler provider-function simple-negotiate + "Accept-Charset" :neg-charset "*")) + +(defn wrap-accept-encoding [handler provider-function] + (wrap-accept-header handler provider-function simple-negotiate + "Accept-Encoding" :neg-encoding "*")) + +(defn send-response [response] + response) + +(defn handle-missing-resource [request] + {:status 404 :body "Missing resource not implemented."}) + +(defn handle-delete [m request] + (send-response (m :delete))) + +(defn accept-entity [m request] + (let [content-type ((request :header) "Content-Type" "application/octet-stream")] + (comment ;; Todo: search (m :accept-content-type-handlers) + ))) + +(defn assert-valid-redirect [resp] + (if (and (= (resp :status) 303) (not (-> resp :header "Location"))) + { :status 500 :body "Response was redirect but no location." } + resp)) + +(defn handle-post-and-redirect [m request] + (assert-valid-redirect + (if ((m :post-is-create) request) + (let [new-path ((m :create-path) request) + request (assoc request :path new-path)] + (accept-entity m request)) + ((m :process-post) request)))) + + + +(defn handle-post [m request] + (if (evaluate-generate (m :allow-missing-post) request) + (handle-post-and-redirect m request) + 404)) + +(defn handle-put [m request] + (if ((m :is-conflict) request) + 409 + (accept-entity m request))) + +(defmulti evaluate-body + "Evaluate the generator with the current request. The type of the + generator determines how it is evaluated" + (fn [generator request] + (class generator))) + +(defmethod evaluate-body Fn + [update request] + (update request)) + +(defmethod evaluate-body Map + [content-type-map request] + (let [content-type (-> request ::rest :neg-content-type)] + (if-let [generator (content-type-map content-type)] + (generator request) + {:status 500 + :body (str "No body generation function found for negotiated content type \"" + content-type "\" request is " request)}))) + +(defmethod evaluate-body String + [body request] + body) + +(defn check-multiple [m request] +(trace "c-m" (if (m :multiple-choices?) + 300 + (if (= :get (request :request-method)) + (evaluate-body (m :get) request) + "")))) + + +(defn handle-get-head [m request] + (trace "handle-get-head" + (let [resp (trace "ETag" + (if-let [etag (evaluate-generate (m :generate-etag) request)] + {:headers { "Etag" etag } } {})) + resp (trace "Last-M" + (if-let [lm (evaluate-generate (m :last-modified) request)] + (assoc-in resp [:headers "Last-Modified"] lm) resp)) + resp (trace "Exp" (if-let [exp (evaluate-generate (m :expires) request)] + (assoc-in resp [:headers "Expires"] exp) resp))] + (update-response request resp (check-multiple m request))))) + + + +(defn handle-delete-put-post [m] + (fn [request] + (condp = (request :request-method) + :delete (handle-delete m request) + :post (handle-post m request) + :put (handle-put m request) + (handle-get-head m request)))) + +(defn wrap-log [handler] + (fn [request] + (do (prn (str "Calling " handler " with request " request)) + (let [resp (handler request)] + (prn (str "<- " handler " result " resp)))))) + + +;; handlers must be a map of implementation methods +(defn resource [ & kvs] + (fn [request] + (let [m (merge *default-functions* (apply hash-map kvs))] + ((-> + (handle-delete-put-post m) + (wrap-if-modified-since (m :last-modified)) + (wrap-if-none-match (m :generate-etag)) + (wrap-if-unmodified-since (m :last-modified)) + (wrap-if-match (m :generate-etag)) + (wrap-predicate (m :exists) handle-missing-resource) + (wrap-accept-encoding (m :encodings-provided)) + (wrap-accept-charset (m :charsets-provided)) + (wrap-accept-language (m :languages-provided)) + (wrap-accept (m :content-types-provided)) + (wrap-options (m :options)) + (wrap-predicate (m :valid-entity-length) 413) + (wrap-predicate (m :known-content-type) 415) + (wrap-predicate (m :valid-content-header) 501) + (wrap-allow (m :allowed)) + (wrap-auth (m :authorized)) + (wrap-predicate #(comp not (evaluate-generate (m :malformed) %)) 400) + (wrap-predicate (m :method-allowed) 405) + (wrap-predicate #(comp not (evaluate-generate (m :uri-too-long) %)) 414) + (wrap-predicate (m :known-method) 501) + (wrap-predicate (m :service-available) 503)) + request)))) + + diff --git a/test/test.clj b/test/test.clj new file mode 100644 index 0000000..802aae8 --- /dev/null +++ b/test/test.clj @@ -0,0 +1,57 @@ +;; Copyright (c) Philipp Meier (meier@fnogol.de). 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. + +(ns test + (:use compojure) + (:use compojure-rest) + (:use compojure-rest.resource)) + +(defn hello-resource [request] + ((-> (method-not-allowed) + (wrap-generate-body (fn [r] (str "Hello " ((request :params) :who "stranger")))) + (wrap-etag (comp :who :params)) + (wrap-expiry (constantly 10000)) + (wrap-last-modified -1000) + (wrap-exists (comp not #(some #{%} ["cat"]) :who :params)) + (wrap-auth (comp not #(some #{%} ["evil"]) :who :params)) + (wrap-allow (comp not #(some #{%} ["scott"]) :who :params))) + request)) + + + +(def product-resource + (resource + :content-types-provided [ "text/html", "text/plain"] + :exists (fn [req] (if-let [id (-> req :route-params :id)] + (if (< id 10) + (assoc req ::product (str "P-" id))))) + :generate-etag (fn [req] (str "X-" (req ::product))) + :delete (fn [req] "deleted") + :put (fn [req] (str "PUT: " + ((req :route-params) :id) (req :body))) + :get { + "text/html" (fn [req] (str "

" (req ::product) "

")) + :json (fn [req] (str "JSON: " (req ::product))) + :xml (fn [req] (str "XML:" (req ::product)))})) + + + + +(defroutes my-app + (ANY "/hello/:who" hello-resource) + (ANY "/product/:id" product-resource) + (GET "/simple" (str "simple")) + (GET "/echo/:foo" (fn [req] {:headers { "Content-Type" "text/plain" } :body (str (dissoc req :servlet-request))})) + (GET "*" (page-not-found))) + +(defn main [] + (do + (defserver test-server {:port 8080} "/*" (servlet my-app)) + (start test-server))) + +