diff options
Diffstat (limited to 'compojure-3.2/src/compojure')
24 files changed, 2261 insertions, 0 deletions
diff --git a/compojure-3.2/src/compojure/control.clj b/compojure-3.2/src/compojure/control.clj new file mode 100755 index 0000000..ea45c69 --- /dev/null +++ b/compojure-3.2/src/compojure/control.clj @@ -0,0 +1,73 @@ +;; Copyright (c) James Reeves. 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.control + "Various macros for controling program flow." + (:use clojure.contrib.seq-utils)) + +(defmacro return + "A do block that will always return the argument 'x'." + [x & body] + `(let [x# ~x] + (do ~@body x#))) + +(defmacro maybe + "Returns (f x & xs) if x is not nil, otherwise returns nil." + [f x & xs] + `(if (not (nil? ~x)) + (~f ~x ~@xs))) + +(defmacro domap + "Similar to doseq, but collects the results into a sequence." + [[item list] & body] + `(map (fn [~item] ~@body) (doall ~list))) + +(defmacro redef + "Redefine an existing value, keeping the metadata intact." + [name value] + `(let [m# (meta #'~name) + v# (def ~name ~value)] + (alter-meta! v# merge m#) + v#)) + +(defmacro decorate + "Wrap a function in one or more decorators." + [func & decorators] + `(redef ~func (-> ~func ~@decorators))) + +(defmacro decorate-with + "Wrap multiple functions in a decorator." + [decorator & funcs] + `(do ~@(for [f funcs] + `(redef ~f (~decorator ~f))))) + +(defmacro decorate-bind + "Wrap named functions in a decorator for a bounded scope." + [decorator funcs & body] + `(binding + [~@(mapcat (fn [f] [f (list decorator f)]) funcs)] + ~@body)) + +(defn apply-doc + "Return a symbol and body with an optional docstring applied." + [name doc? body] + (if (string? doc?) + (list* (with-meta name (assoc (meta name) :doc doc?)) body) + (list* name doc? body))) + +(defmacro deftmpl + "Define a template function. Arguments are passed via key-value pairs. + e.g. (deftmpl foo [bar baz] (+ bar baz)) + (foo :bar 1 :baz 2)" + [name doc? & body] + (let [[name params & body] (apply-doc name doc? body)] + `(defn ~name + ~@doc? + [& param-map#] + (let [{:keys ~params} (apply hash-map param-map#)] + ~@body)))) diff --git a/compojure-3.2/src/compojure/crypto.clj b/compojure-3.2/src/compojure/crypto.clj new file mode 100755 index 0000000..937bad5 --- /dev/null +++ b/compojure-3.2/src/compojure/crypto.clj @@ -0,0 +1,129 @@ +;; Copyright (c) James Reeves. 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.crypto + "Functions for cryptographically signing, verifying and encrypting data." + (:use compojure.encodings + clojure.contrib.def + clojure.contrib.java-utils) + (:import java.security.SecureRandom + [javax.crypto Cipher KeyGenerator Mac] + [javax.crypto.spec SecretKeySpec IvParameterSpec] + java.util.UUID)) + +(defvar hmac-defaults + {:algorithm "HmacSHA256"} + "Default options for HMACs.") + +(defvar encrypt-defaults + {:algorithm "AES" + :key-size 128 + :mode "CBC" + :padding "PKCS5Padding"} + "Default options for symmetric encryption.") + +(defn secure-random-bytes + "Returns a random byte array of the specified size. Can optionally supply + an PRNG algorithm (defaults is SHA1PRNG)." + ([size] + (secure-random-bytes size "SHA1PRNG")) + ([size algorithm] + (let [seed (make-array Byte/TYPE size)] + (.nextBytes (SecureRandom/getInstance algorithm) seed) + seed))) + +(defn gen-secret-key + "Generate a random secret key from a map of encryption options." + ([] + (gen-secret-key {})) + ([options] + (secure-random-bytes (/ (options :key-size) 8)))) + +(defn gen-uuid + "Generate a random UUID." + [] + (str (UUID/randomUUID))) + +(defn- to-bytes + "Converts its argument into an array of bytes." + [x] + (cond + (string? x) (.getBytes x) + (sequential? x) (into-array Byte/TYPE x) + :else x)) + +(defn hmac-bytes + "Generate a HMAC byte array with the supplied key on a byte array of data. + Takes an optional map of cryptography options." + [options key data] + (let [options (merge hmac-defaults options) + algorithm (options :algorithm) + hmac (doto (Mac/getInstance algorithm) + (.init (SecretKeySpec. key algorithm)))] + (.doFinal hmac data))) + +(defn hmac + "Generate a Basc64-encoded HMAC with the supplied key on a byte array or + string of data. Takes an optional map of cryptography options." + [options key data] + (base64-encode-bytes (hmac-bytes options key (to-bytes data)))) + +(defn- make-algorithm + "Return an algorithm string suitable for JCE from a map of options." + [options] + (str "AES/" (options :mode) "/" (options :padding))) + +(defn- make-cipher + "Create an AES Cipher instance." + [options] + (Cipher/getInstance (make-algorithm options))) + +(defn encrypt-bytes + "Encrypts a byte array with the given key and encryption options." + [options key data] + (let [options (merge encrypt-defaults options) + cipher (make-cipher options) + secret-key (SecretKeySpec. key (options :algorithm)) + iv (secure-random-bytes (.getBlockSize cipher))] + (.init cipher Cipher/ENCRYPT_MODE secret-key (IvParameterSpec. iv)) + (to-bytes (concat iv (.doFinal cipher data))))) + +(defn decrypt-bytes + "Decrypts a byte array with the given key and encryption options." + [options key data] + (let [options (merge encrypt-defaults options) + cipher (make-cipher options) + [iv data] (split-at (.getBlockSize cipher) data) + iv-spec (IvParameterSpec. (to-bytes iv)) + secret-key (SecretKeySpec. key (options :algorithm))] + (.init cipher Cipher/DECRYPT_MODE secret-key iv-spec) + (.doFinal cipher (to-bytes data)))) + +(defn encrypt + "Encrypts a string or byte array with the given key and encryption options." + [options key data] + (base64-encode-bytes (encrypt-bytes options key (to-bytes data)))) + +(defn decrypt + "Base64 encodes and encrypts a string with the given key and algorithm." + [options key data] + (String. (decrypt-bytes options key (base64-decode-bytes data)))) + +(defn seal + "Seal a data structure into a cryptographically secure string. Ensures no-one + looks at or tampers with the data inside." + [key data] + (let [data (encrypt {} key (marshal data))] + (str data "--" (hmac {} key data)))) + +(defn unseal + "Read a cryptographically sealed data structure." + [key data] + (let [[data mac] (.split data "--")] + (if (= mac (hmac {} key data)) + (unmarshal (decrypt {} key data))))) diff --git a/compojure-3.2/src/compojure/encodings.clj b/compojure-3.2/src/compojure/encodings.clj new file mode 100755 index 0000000..6587d48 --- /dev/null +++ b/compojure-3.2/src/compojure/encodings.clj @@ -0,0 +1,64 @@ +;; Copyright (c) James Reeves. 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.encodings + "Functions for encoding data." + (:use compojure.str-utils + clojure.contrib.duck-streams) + (:import [java.net URLEncoder URLDecoder] + [org.apache.commons.codec.binary Base64 Hex])) + +(defn urlencode + "Encode a urlencoded string using the default encoding." + [s] + (URLEncoder/encode (str* s) *default-encoding*)) + +(defn urldecode + "Decode a urlencoded string using the default encoding." + [s] + (URLDecoder/decode s *default-encoding*)) + +(defn base64-encode-bytes + "Encode an array of bytes into a base64 encoded string." + [unencoded] + (String. (Base64/encodeBase64 unencoded))) + +(defn base64-encode + [unencoded] + "Encode a string using base64." + (base64-encode-bytes (.getBytes unencoded))) + +(defn base64-decode-bytes + "Decode a string using base64 into an array of bytes." + [encoded] + (Base64/decodeBase64 (.getBytes encoded))) + +(defn base64-decode + "Decode a string using base64." + [encoded] + (String. (base64-decode-bytes encoded))) + +(defn marshal + "Serialize a Clojure object in a base64-encoded string." + [data] + (base64-encode (pr-str data))) + +(defn unmarshal + "Unserialize a Clojure object from a base64-encoded string." + [marshaled] + (read-string (base64-decode marshaled))) + +(defn decode-hex + "Converts a string of hex into it's corresponding byte array." + [s] + (Hex/decodeHex (.toCharArray s))) + +(defn encode-hex + "Converts a byte array into it's corresponding hex String." + [array] + (String. (Hex/encodeHex array))) diff --git a/compojure-3.2/src/compojure/html.clj b/compojure-3.2/src/compojure/html.clj new file mode 100755 index 0000000..d106263 --- /dev/null +++ b/compojure-3.2/src/compojure/html.clj @@ -0,0 +1,16 @@ +;; Copyright (c) James Reeves. 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.html + "Shortcut to include all compojure.http.* namespaces." + (:use compojure.ns-utils)) + +(immigrate + 'compojure.html.gen + 'compojure.html.page-helpers + 'compojure.html.form-helpers) diff --git a/compojure-3.2/src/compojure/html/form_helpers.clj b/compojure-3.2/src/compojure/html/form_helpers.clj new file mode 100755 index 0000000..9da2ef9 --- /dev/null +++ b/compojure-3.2/src/compojure/html/form_helpers.clj @@ -0,0 +1,169 @@ +;; Copyright (c) James Reeves. 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.html.form-helpers + "Functions for generating HTML forms and input fields." + (:use compojure.html.gen + compojure.control + compojure.str-utils + clojure.contrib.def + clojure.contrib.seq-utils)) + +;; Global parameters for easy default values + +(defvar *params* {} + "Parameter map var that form input field functions use to populate their + default values.") + +(defmacro with-params + "Bind a map of params to *params*." + [params & body] + `(binding [*params* ~params] + ~@body)) + +;; Form input fields + +(defn- input-field + "Creates a form input field." + [type name value] + (let [name (str* name) + attrs {:type type, :name name, :id name} + attrs (if value + (assoc attrs :value value) + attrs)] + [:input attrs])) + +(defn hidden-field + "Creates a hidden input field." + ([name] (hidden-field name (*params* name))) + ([name value] (input-field "hidden" name value))) + +(defn text-field + "Creates a text input field." + ([name] (text-field name (*params* name))) + ([name value] (input-field "text" name value))) + +(defn password-field + "Creates a password input field." + [name] + (input-field "password" name "")) + +(defn check-box + "Creates a check box." + ([name] + (check-box name (*params* name))) + ([name checked?] + (check-box name checked? "true")) + ([name checked? value] + [:input {:type "checkbox" + :name (str* name) + :id (str* name) + :value value + :checked checked?}])) + +(defn radio-button + "Creates a radio button." + ([group] + (radio-button group (*params* group))) + ([group checked?] + (radio-button group checked? "true")) + ([group checked? value] + [:input {:type "radio" + :name (str* group) + :id (str* group "_" value) + :value value + :checked checked?}])) + +(defn select-options + "Turn a collection into a set of option tags." + ([options] + (select-options options nil)) + ([options selected] + (let [select (fn [opt attrs] + (if (and selected (= opt (str* selected))) + (merge attrs {:selected "selected"}) + attrs))] + (domap [opt options] + (if (vector? opt) + (let [text (opt 0) + value (str* (opt 1))] + [:option (select value {:value value}) text]) + [:option (select opt {}) opt]))))) + +(defn drop-down + "Creates a drop-down box using the 'select' tag." + ([name options] + (drop-down name options (*params* name))) + ([name options selected] + [:select {:name (str* name) :id (str* name)} + (select-options options selected)])) + +(defn text-area + "Creates a text area element." + ([name] + (text-area name (*params* name))) + ([name value] + [:textarea {:name (str* name) :id (str* name)} value])) + +(defn file-upload + "Creates a file upload input." + [name] + [:input {:type "file", :name (str* name), :id (str* name)}]) + +(defn label + "Create a label for an input field with the supplied name." + [name text] + [:label {:for (str* name)} text]) + +(defn submit-button + "Create a submit button." + [text] + [:input {:type "submit" :value text}]) + +(defn reset-button + "Create a form reset button." + [text] + [:input {:type "reset" :value text}]) + +(defn form-to + "Create a form that points to a particular method and route. + e.g. (form-to [:put \"/post\"] + ...)" + [[method action] & body] + (let [method-str (upcase-name method)] + (into [] + (concat + (if (includes? [:get :post] method) + [:form {:method method-str :action action}] + [:form {:method "POST" :action action} + (hidden-field "_method" method-str)]) + body)))) + +(decorate-with optional-attrs + hidden-field + text-field + check-box + drop-down + text-area + file-upload + label + submit-button + reset-button + form-to) + +(defmacro decorate-fields + "Wrap all input field functions in a decorator." + [decorator & body] + `(decorate-bind ~decorator + [text-field + password-field + check-box + drop-down + text-area + file-upload] + (list ~@body))) diff --git a/compojure-3.2/src/compojure/html/gen.clj b/compojure-3.2/src/compojure/html/gen.clj new file mode 100755 index 0000000..617190d --- /dev/null +++ b/compojure-3.2/src/compojure/html/gen.clj @@ -0,0 +1,124 @@ +;; Copyright (c) James Reeves. 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.html.gen + "A library for generating HTML output from a tree of vectors. The first item + of the vector is the tag name, the optional second item is a hash of + attributes, and the rest is the body of the tag." + (:use compojure.str-utils + clojure.contrib.def)) + +(defn optional-attrs + "Adds an optional attribute map to the supplied function's arguments." + [func] + (fn [attrs & body] + (if (map? attrs) + (let [[tag func-attrs & body] (apply func body)] + (apply vector tag (merge func-attrs attrs) body)) + (apply func attrs body)))) + +(defn escape-html + "Change special characters into HTML character entities." + [string] + (.. (str string) + (replace "&" "&") + (replace "<" "<") + (replace ">" ">") + (replace "\"" """))) + +(defvar h escape-html + "Shortcut for escape-html") + +(defn- map-to-attrs + "Turn a map into a string of HTML attributes, sorted by attribute name." + [attrs] + (map-str + (fn [[key val]] + (if key + (str " " key "=\"" (h val) "\""))) + (sort + (map (fn [[key val]] + (cond + (true? val) [(str* key) (str* key)] + (not val) [nil nil] + :else [(str* key) (str* val)])) + attrs)))) + +(defn- create-tag + "Wrap some content in an HTML tag." + [tag attrs content] + (str* "<" tag (map-to-attrs attrs) ">" + content + "</" tag ">")) + +(defn- create-closed-tag + "Make a closed XML tag with no content." + [tag attrs] + (str* "<" tag (map-to-attrs attrs) " />")) + +(defn- expand-seqs + "Expand out all the sequences in a collection." + [coll] + (mapcat + #(if (or (seq? %) (nil? %)) + % + (list %)) + coll)) + +(defn- ensure-attrs + "Ensure the tag has a map of attributes." + [[tag & body]] + (if (map? (first body)) + (list* tag body) + (list* tag {} body))) + +(defvar- css-lexer #"([^\s\.#]+)(?:#([^\s\.#]+))?(?:\.([^\s#]+))?") + +(defn- parse-css-tag + "Pulls the id and class attributes from a tag name formatted in a CSS style. + e.g. :div#content -> [:div {:id \"content\"}] + :span.error -> [:span {:class \"error\"}]" + [tag attrs] + (let [[_ tag id classes] (re-matches css-lexer (str* tag)) + attrs (merge attrs + (if id {:id id}) + (if classes + {:class (.replace classes "." " ")}))] + [tag attrs])) + +(declare html) + +(defvar- container-tags + #{:a :b :body :dd :div :dl :dt :em :fieldset :form :h1 :h2 :h3 :h4 :h5 :h6 + :head :html :i :label :li :ol :pre :script :span :strong :style :textarea + :ul} + "A list of tags that need an explicit ending tag when rendered.") + +(defn explicit-ending-tag? + "Returns true if tag needs an explicit ending tag, even if the body of the + tag is empty." + [tag] + (container-tags (keyword (str* tag)))) + +(defn html-tree + "Turns a tree of vectors into a string of HTML. Any sequences in the + tree are expanded out." + [tree] + (if (vector? tree) + (let [[tag attrs & body] (ensure-attrs tree) + [tag attrs] (parse-css-tag tag attrs) + body (expand-seqs body)] + (if (or (seq body) (explicit-ending-tag? tag)) + (create-tag tag attrs (apply html body)) + (create-closed-tag tag attrs))) + (str tree))) + +(defn html + "Format trees of vectors into a string of HTML." + [& trees] + (map-str html-tree (expand-seqs trees))) diff --git a/compojure-3.2/src/compojure/html/page_helpers.clj b/compojure-3.2/src/compojure/html/page_helpers.clj new file mode 100755 index 0000000..8c10e30 --- /dev/null +++ b/compojure-3.2/src/compojure/html/page_helpers.clj @@ -0,0 +1,103 @@ +;; Copyright (c) James Reeves. 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.html.page-helpers + "Functions for generating document and header boilerplate." + (:use compojure.control + compojure.html.gen + compojure.str-utils + clojure.contrib.str-utils) + (:import java.net.URLEncoder)) + +(def doctype + {:html4 + (str "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\" " + "\"http://www.w3.org/TR/html4/strict.dtd\">\n") + + :html5 + (str "<!DOCTYPE html>") + + :xhtml-strict + (str "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " + "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n") + + :xhtml-transitional + (str "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" " + "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n")}) + +(defn xhtml-tag + "Create an XHTML tag for the specified locale. + e.g. (xhtml \"en\" + [:head ...] + [:body ...])" + [lang & contents] + [:html {:xmlns "http://www.w3.org/1999/xhtml" + "xml:lang" lang + :lang lang} + contents]) + +(defn include-js + "Include a list of external javascript files." + [& scripts] + (domap [script scripts] + [:script {:type "text/javascript" :src script}])) + +(defn include-css + "Include a list of external stylesheet files." + [& styles] + (domap [style styles] + [:link {:type "text/css" :href style :rel "stylesheet"}])) + +(defn javascript-tag + "Wrap the supplied javascript up in script tags and a CDATA section." + [script] + [:script {:type "text/javascript"} + (str "//<![CDATA[\n" script "\n//]]>")]) + +(defn link-to + "Wraps some content in a HTML hyperlink with the supplied URL." + [url & content] + [:a {:href url} content]) + +(defn url-encode + "Encodes a single string or sequence of key/value pairs." + [string-or-map] + (let [enc #(URLEncoder/encode (str* %))] + (if (string? string-or-map) + (enc string-or-map) + (str-join "&" + (map (fn [[key val]] (str (enc key) "=" (enc val))) + string-or-map))))) + +(defn url-params + "Encodes a map of parameters and adds them onto the end of an existing + address. + e.g. (url-params \"http://example.com\" {:lang \"en\", :offset 10}) + => \"http://example.com?lang=en&offset=10\"" + [address param-map] + (str address "?" (url-encode param-map))) + +(defn unordered-list + "Wrap a collection in an unordered list" + [coll] + [:ul {} + (domap [x coll] + [:li x])]) + +(defn ordered-list + "Wrap a collection in an unordered list" + [coll] + [:ol {} + (domap [x coll] + [:li x])]) + +(decorate-with optional-attrs + xhtml-tag + link-to + unordered-list + ordered-list) diff --git a/compojure-3.2/src/compojure/http.clj b/compojure-3.2/src/compojure/http.clj new file mode 100755 index 0000000..af9881a --- /dev/null +++ b/compojure-3.2/src/compojure/http.clj @@ -0,0 +1,19 @@ +;; Copyright (c) James Reeves. 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.http + "Shortcut to include compojure.http.routes, compojure.http.helpers and + compojure.http.servlet." + (:use compojure.ns-utils)) + +(immigrate + 'compojure.http.helpers + 'compojure.http.middleware + 'compojure.http.multipart + 'compojure.http.routes + 'compojure.http.servlet) diff --git a/compojure-3.2/src/compojure/http/helpers.clj b/compojure-3.2/src/compojure/http/helpers.clj new file mode 100755 index 0000000..f60eeb9 --- /dev/null +++ b/compojure-3.2/src/compojure/http/helpers.clj @@ -0,0 +1,76 @@ +;; Copyright (c) James Reeves. 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.http.helpers + "Helper functions for things like redirection, serving files, 404s, etc." + (:use compojure.encodings + compojure.str-utils + clojure.contrib.def + clojure.contrib.str-utils + clojure.contrib.duck-streams) + (:import java.io.File)) + +(defn- encode-cookie + "Encode sequence of key/value pairs a cookie." + [name value attrs] + (str-join "; " + (cons (str (urlencode name) "=" (urlencode value)) + (for [[key val] attrs] (str* key "=" val))))) + +(defn set-cookie + "Return a Set-Cookie header." + ([name value] + {:headers {"Set-Cookie" (encode-cookie name value nil)}}) + ([name value & attrs] + {:headers {"Set-Cookie" (encode-cookie name value (partition 2 attrs))}})) + +(defn content-type + "Retuns a Content-Type header given a type string." + [type] + {:headers {"Content-Type" type}}) + +(defn redirect-to + "A shortcut for a '302 Moved' HTTP redirect." + [location] + [302 {:headers {"Location" location}}]) + +(defn page-not-found + "A shortcut to create a '404 Not Found' HTTP response." + ([] + (page-not-found "public/404.html")) + ([filename] + [404 (File. filename)])) + +(defn- find-index-file + "Search the directory for index.*" + [dir] + (first + (filter + #(.startsWith (.toLowerCase (.getName %)) "index.") + (.listFiles dir)))) + +(defn safe-path? + "Is a filepath safe for a particular root?" + [root path] + (.startsWith (.getCanonicalPath (File. root path)) + (.getCanonicalPath (File. root)))) + +(defn serve-file + "Attempts to serve up a static file from a directory, which defaults to + './public'. Nil is returned if the file does not exist. If the file is a + directory, the function looks for a file in the directory called 'index.*'." + ([path] + (serve-file "public" path)) + ([root path] + (let [filepath (File. root path)] + (if (safe-path? root path) + (cond + (.isFile filepath) + filepath + (.isDirectory filepath) + (find-index-file filepath)))))) diff --git a/compojure-3.2/src/compojure/http/middleware.clj b/compojure-3.2/src/compojure/http/middleware.clj new file mode 100755 index 0000000..f9a2dab --- /dev/null +++ b/compojure-3.2/src/compojure/http/middleware.clj @@ -0,0 +1,131 @@ +;; Copyright (c) James Reeves. 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.http.middleware + "Various middleware functions." + (:use compojure.http.routes + compojure.str-utils + clojure.contrib.def + clojure.contrib.str-utils)) + +(defn header-option + "Converts a header option KeyValue into a string." + [[key val]] + (cond + (true? val) (str* key) + (false? val) nil + :otherwise (str* key "=" val))) + +(defn header-options + "Converts a map into an HTTP header options string." + [m delimiter] + (str-join delimiter + (remove nil? (map header-option m)))) + +(defn with-headers + "Merges a map of header name and values into the response. Overwrites + existing headers." + [handler headers] + (fn [request] + (if-let [response (handler request)] + (assoc response :headers + (merge (:headers response) headers))))) + +(defn with-cache-control + "Middleware to set the Cache-Control http header. Map entries with boolean + values either write their key if true, or nothing if false. + Example: + {:max-age 3600 :public false :must-revalidate true} + => Cache-Control: max-age=3600, must-revalidate" + [handler header-map] + (with-headers handler + {"Cache-Control" (header-options header-map ", ")})) + +(defn with-uri-rewrite + "Rewrites a request uri with the result of calling f with the + request's original uri. If f returns nil the handler is not called." + [handler f] + (fn [request] + (let [uri (:uri request) + rewrite (f uri)] + (if rewrite + (handler (assoc request :uri rewrite)) + nil)))) + +(defn- remove-or-nil-context + "Removes a context string from the front of a uri. If it wasn't there, + returns nil." + [uri context] + (if (.startsWith uri context) + (if-not (= uri context) + (subs uri (count context)) + "/") + nil)) + +(defn with-context + "Removes the context string from the beginning of the request uri + such that route matching is done without it. If the context is not + present, the handler will not be called." + [handler context] + (with-uri-rewrite handler #(remove-or-nil-context % context))) + +(defn- uri-snip-slash + "Removes a trailing slash from all uris except \"/\"." + [uri] + (if (and (not (= "/" uri)) + (.endsWith uri "/")) + (chop uri) + uri)) + +(defn ignore-trailing-slash + "Makes routes match regardless of whether or not a uri ends in a slash." + [handler] + (with-uri-rewrite handler uri-snip-slash)) + +(defvar default-mimetypes + {"css" "text/css" + "gif" "image/gif" + "gz" "application/gzip" + "htm" "text/html" + "html" "text/html" + "jpg" "image/jpeg" + "js" "text/javascript" + "pdf" "application/pdf" + "png" "image/png" + "swf" "application/x-shockwave-flash" + "txt" "text/plain" + "xml" "text/xml" + "zip" "application/zip"} + "Default mimetype map used by with-mimetypes.") + +(defn- extension + "Returns the text after the last . of a String or nil." + [s] + (second (re-find #"\.(\w*$)" s))) + +(defn- request-mimetype + "Derives the mimetype from a request. See with-mimetypes for options." + [request options] + (let [default (or (:default options) "text/html")] + (if-let [ext (extension (:uri request))] + (let [mimetypes (or (:mimetypes options) default-mimetypes)] + (get mimetypes ext default)) + default))) + +(defn with-mimetypes + "Middleware to add the proper Content-Type header based on the uri of + the request. options is a map containing a :mimetype map of extension + to type and a :default mime type. If :mimetype is not provided, a default + map with common mime types will be used. If :default is not provided, + \"text/html\" is used." + ([handler] + (with-mimetypes handler {})) + ([handler options] + (fn [request] + (let [mimetype (request-mimetype request options)] + ((with-headers handler {"Content-Type" mimetype}) request))))) diff --git a/compojure-3.2/src/compojure/http/multipart.clj b/compojure-3.2/src/compojure/http/multipart.clj new file mode 100755 index 0000000..afd6737 --- /dev/null +++ b/compojure-3.2/src/compojure/http/multipart.clj @@ -0,0 +1,80 @@ +;; Copyright (c) James Reeves. 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.http.multipart + "Add multipart form handling to Compojure. Relies on the Apache Commons + FileUpload library." + (:use clojure.contrib.def + compojure.map-utils) + (:import [org.apache.commons.fileupload FileUpload RequestContext] + [org.apache.commons.fileupload.disk DiskFileItemFactory DiskFileItem])) + +(defn multipart-form? + "Does a request have a multipart form?" + [request] + (if-let [content-type (:content-type request)] + (.startsWith content-type "multipart/form-data"))) + +(defvar- file-upload + (FileUpload. + (doto (DiskFileItemFactory.) + (.setSizeThreshold -1) + (.setFileCleaningTracker nil))) + "Uploader class to save multipart form values to temporary files.") + +(defn- request-context + "Create a RequestContext object from a request map." + [request] + (proxy [RequestContext] [] + (getContentType [] (:content-type request)) + (getContentLength [] (:content-length request)) + (getCharacterEncoding [] (:character-encoding request)) + (getInputStream [] (:body request)))) + +(defn- file-map + "Create a file map from a DiskFileItem." + [#^DiskFileItem item] + {:disk-file-item item + :filename (.getName item) + :size (.getSize item) + :content-type (.getContentType item) + :tempfile (.getStoreLocation item)}) + +(defn parse-multipart-params + "Parse a map of multipart parameters from the request." + [request] + (reduce + (fn [param-map, #^DiskFileItem item] + (assoc-vec param-map + (keyword (.getFieldName item)) + (if (.isFormField item) + (if (zero? (.getSize item)) + "" + (.getString item)) + (file-map item)))) + {} + (.parseRequest + file-upload + (request-context request)))) + +(defn get-multipart-params + "Retrieve multipart params from the request." + [request] + (if (multipart-form? request) + (parse-multipart-params request) + {})) + +(defn with-multipart + "Decorate a Ring handler with multipart parameters." + [handler] + (fn [request] + (let [params (get-multipart-params request) + request (-> request + (assoc :multipart-params params) + (assoc :params (merge (request :params) params)))] + (handler request)))) diff --git a/compojure-3.2/src/compojure/http/request.clj b/compojure-3.2/src/compojure/http/request.clj new file mode 100755 index 0000000..8c09616 --- /dev/null +++ b/compojure-3.2/src/compojure/http/request.clj @@ -0,0 +1,109 @@ +;; Copyright (c) James Reeves. 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.http.request + "Functions for pulling useful data out of a HTTP request map." + (:use compojure.control + compojure.encodings + compojure.map-utils + compojure.str-utils + clojure.contrib.duck-streams + clojure.contrib.str-utils) + (:import java.net.URLDecoder + java.io.InputStreamReader)) + +(defn- parse-params + "Parse parameters from a string into a map." + [param-string separator] + (reduce + (fn [param-map s] + (if-let [[_ key val] (re-matches #"([^=]+)=(.*)" s)] + (assoc-vec param-map + (keyword (urldecode key)) + (urldecode (or val ""))) + param-map)) + {} + (remove blank? + (re-split separator param-string)))) + +(defn parse-query-params + "Parse parameters from the query string." + [request] + (if-let [query (request :query-string)] + (parse-params query #"&"))) + +(defn get-character-encoding + "Get the character encoding, or use the default from duck-streams." + [request] + (or (request :character-encoding) *default-encoding*)) + +(defn- slurp-body + "Slurp the request body into a string." + [request] + (let [encoding (get-character-encoding request)] + (if-let [body (request :body)] + (slurp* (InputStreamReader. body encoding))))) + +(defn urlencoded-form? + "Does a request have a urlencoded form?" + [request] + (if-let [type (:content-type request)] + (.startsWith type "application/x-www-form-urlencoded"))) + +(defn parse-form-params + "Parse urlencoded form parameters from the request body." + [request] + (if (urlencoded-form? request) + (if-let [body (slurp-body request)] + (parse-params body #"&")))) + +(defn- get-merged-params + "Get a map of all the parameters merged together." + [request] + (merge (:query-params request) + (:form-params request) + (:params request))) + +(defn- assoc-func + "Associate the result of a (func request) with a key on the request map." + [request key func] + (if (contains? request key) + request + (assoc request key (or (func request) {})))) + +(defn assoc-params + "Associate urlencoded parameters with a request. The following keys are added + to the request map: :query-params, :form-params and :params." + [request] + (-> request + (assoc-func :query-params parse-query-params) + (assoc-func :form-params parse-form-params) + (assoc-func :params get-merged-params))) + +(defn with-request-params + "Decorator that adds urlencoded parameters to the request map." + [handler] + (fn [request] + (handler (assoc-params request)))) + +(defn parse-cookies + "Pull out a map of cookies from a request map." + [request] + (if-let [cookies (get-in request [:headers "cookie"])] + (parse-params cookies #";\s*"))) + +(defn assoc-cookies + "Associate cookies with a request map." + [request] + (assoc-func request :cookies parse-cookies)) + +(defn with-cookies + "Decorator that adds cookies to a request map." + [handler] + (fn [request] + (handler (assoc-cookies request)))) diff --git a/compojure-3.2/src/compojure/http/response.clj b/compojure-3.2/src/compojure/http/response.clj new file mode 100755 index 0000000..269e71d --- /dev/null +++ b/compojure-3.2/src/compojure/http/response.clj @@ -0,0 +1,106 @@ +;; Copyright (c) James Reeves. 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.http.response + "Parse a Compojure route return value into a HTTP response map." + (:use clojure.contrib.def + compojure.http.helpers) + (:import clojure.lang.Fn + clojure.lang.IPersistentVector + java.util.Map + clojure.lang.ISeq + java.io.File + java.io.InputStream + java.net.URL + clojure.lang.Keyword)) + +(defmulti update-response + "Update a response with an object. The type of object determines how the + response is updated." + (fn [request reponse update] + (class update))) + +(defmethod update-response Integer + [request response status] + (assoc response :status status)) + +(defmethod update-response String + [request response body] + (let [headers (merge (:headers (content-type "text/html")) (:headers response)) + response (assoc response :headers headers)] + (if (string? (:body response)) + (merge-with str response {:body body}) + (assoc response :body body)))) + +(defmethod update-response ISeq + [request response sequence] + (assoc response :body sequence)) + +(defmethod update-response File + [request response file] + (assoc response :body file)) + +(defmethod update-response InputStream + [request response stream] + (assoc response :body stream)) + +(defmethod update-response URL + [request response url] + (assoc response :body (.openStream url))) + +(defmethod update-response IPersistentVector + [request response updates] + (reduce (partial update-response request) response updates)) + +(defmethod update-response Keyword + [request response kw] + (if (not= kw :next) + (update-response request response (str kw)))) + +(defmethod update-response Fn + [request response func] + (update-response request response (func request))) + +(defmethod update-response nil + [request response _] + response) + +(defn- merge-map + "Merges an inner map in 'from' into 'to'" + [to key from] + (merge-with merge to (select-keys from [key]))) + +(defn- merge-bodies + "Merge the bodies in 'from' into 'to'." + [to from] + (let [from (select-keys from [:body])] + (if (and (-> to :body string?) (-> from :body string?)) + (merge-with str to from) + (merge to from)))) + +(defn- merge-rest + "Merge everything but the headers, session and body." + [to from] + (merge to (dissoc from :headers :session :body))) + +(defmethod update-response Map + [request response update-map] + (-> response + (merge-map :headers update-map) + (merge-map :session update-map) + (merge-bodies update-map) + (merge-rest update-map))) + +(defvar default-response + {:status 200, :headers {}} + "Default HTTP response map.") + +(defn create-response + "Create a new response map from an update object, x." + [request x] + (update-response request default-response x)) diff --git a/compojure-3.2/src/compojure/http/routes.clj b/compojure-3.2/src/compojure/http/routes.clj new file mode 100755 index 0000000..d722a57 --- /dev/null +++ b/compojure-3.2/src/compojure/http/routes.clj @@ -0,0 +1,243 @@ +;; Copyright (c) James Reeves. 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.http.routes + "Macros and functions for compiling routes in the form (method path & body) + into stand-alone functions that return the return value of the body, or the + keyword :next if they don't match." + (:use compojure.http.request + compojure.http.response + compojure.http.session + compojure.str-utils + compojure.map-utils + compojure.control + compojure.encodings) + (:import java.util.regex.Pattern + java.util.Map)) + +;; Functions for lexing a string + +(defn- lex-1 + "Lex one symbol from a string, and return the symbol and trailing source." + [src clauses] + (some + (fn [[re action]] + (let [matcher (re-matcher re src)] + (if (.lookingAt matcher) + [(if (fn? action) (action matcher) action) + (.substring src (.end matcher))]))) + (partition 2 clauses))) + +(defn- lex + "Lex a string into tokens by matching against regexs and evaluating + the matching associated function." + [src & clauses] + (loop [results [] + src src + clauses clauses] + (if-let [[result src] (lex-1 src clauses)] + (let [results (conj results result)] + (if (= src "") + results + (recur results src clauses)))))) + +;; Functions for matching URIs using a syntax borrowed from Ruby frameworks +;; like Sinatra and Rails. + +(defstruct uri-matcher + :regex + :keywords) + +(defn compile-uri-matcher + "Compile a path string using the routes syntax into a uri-matcher struct." + [path] + (let [splat #"\*" + word #":([A-Za-z][\w-]*)" + literal #"(:[^A-Za-z*]|[^:*])+"] + (struct uri-matcher + (re-pattern + (apply str + (lex path + splat "(.*?)" + word "([^/.,;?]+)" + literal #(re-escape (.group %))))) + (vec + (remove nil? + (lex path + splat :* + word #(keyword (.group % 1)) + literal nil)))))) + +;; Don't compile paths more than once. +(decorate-with memoize compile-uri-matcher) + +(defmulti compile-matcher + "Compile a string or regex into a form suitable for buing passed to the + match-uri function." + class) + +(defmethod compile-matcher String + [path] + (compile-uri-matcher path)) + +(defmethod compile-matcher Pattern + [re] + re) + +(defn- assoc-keywords-with-groups + "Create a hash-map from a series of regex match groups and a collection of + keywords." + [groups keywords] + (reduce + (fn [m [k v]] (assoc-vec m k v)) + {} + (map vector keywords groups))) + +(defmulti match-uri + "Match a URL against a compiled URI-matcher or a regular expression. Returns + the matched URI keywords as a map, or the matched regex groups as a vector." + (fn [matcher uri] (class matcher))) + +(defmethod match-uri Map + [uri-matcher uri] + (let [matcher (re-matcher (uri-matcher :regex) (or uri "/"))] + (if (.matches matcher) + (assoc-keywords-with-groups + (map urldecode (re-groups* matcher)) + (uri-matcher :keywords))))) + +(defmethod match-uri Pattern + [uri-pattern uri] + (let [matches (re-matches uri-pattern (or uri "/"))] + (if matches + (if (vector? matches) + (vec (map urldecode (rest matches))) + [])))) + +(defn match-method + "True if this request matches the supplied method." + [method request] + (let [request-method (request :request-method) + form-method (-> request :form-params :_method)] + (or (nil? method) + (if (and form-method (= request-method :post)) + (= (upcase-name method) form-method) + (= method request-method))))) + +(defn request-url + "Return the complete URL for the request." + [request] + (str + (name (:scheme request)) + "://" + (get-in request [:headers "host"]) + (:uri request))) + +(defn absolute-url? + "True if the string is an absolute URL." + [s] + (re-find #"^[a-z+.-]+://" s)) + +(defn get-matcher-uri + "Get the appropriate request URI for the given path pattern." + [path request] + (if (and (string? path) (absolute-url? path)) + (request-url request) + (:uri request))) + +(defmacro request-matcher + "Compiles a function to match a HTTP request against the supplied method + and path template. Returns a map of the route parameters if the is a match, + nil otherwise. Precompiles the route when supplied with a literal string." + [method path] + (let [matcher (if (or (string? path) (instance? Pattern path)) + (compile-matcher path) + `(compile-matcher ~path))] + `(fn [request#] + (and + (match-method ~method request#) + (match-uri ~matcher (get-matcher-uri ~path request#)))))) + +;; Functions and macros for generating routing functions. A routing function +;; returns :next if it doesn't match, and any other value if it does. + +(defmacro with-request-bindings + "Add shortcut bindings for the keys in a request map." + [request & body] + `(let [~'request ~request + ~'params (:params ~'request) + ~'cookies (:cookies ~'request) + ~'session (:session ~'request) + ~'flash (:flash ~'request)] + ~@body)) + +(defn assoc-route-params + "Associate route parameters with the request map." + [request params] + (-> request + (assoc :route-params params) + (assoc :params (merge (:params request) + (if (map? params) params))))) + +(defn compile-route + "Compile a route in the form (method path & body) into a function." + [method path body] + `(let [matcher# (request-matcher ~method ~path)] + (fn [request#] + (if-let [route-params# (matcher# request#)] + (let [request# (assoc-route-params request# route-params#)] + (create-response request# + (with-request-bindings request# ~@body))))))) + +(defn routes* + "Create a Ring handler by combining several handlers into one." + [& handlers] + (fn [request] + (some #(% request) handlers))) + +(defn routes + "Create a Ring handler by combining several routes into one. Adds parameters + and cookies to the request." + [& handlers] + (-> (apply routes* handlers) + with-request-params + with-cookies)) + +;; Macros for easily creating a compiled routing table + +(defmacro defroutes + "Define a Ring handler function from a sequence of routes. Takes an optional + doc-string." + [name doc? & routes] + (let [[name & routes] (apply-doc name doc? routes)] + `(def ~name + (routes ~@routes)))) + +(defmacro GET "Generate a GET route." + [path & body] + (compile-route :get path body)) + +(defmacro POST "Generate a POST route." + [path & body] + (compile-route :post path body)) + +(defmacro PUT "Generate a PUT route." + [path & body] + (compile-route :put path body)) + +(defmacro DELETE "Generate a DELETE route." + [path & body] + (compile-route :delete path body)) + +(defmacro HEAD "Generate a HEAD route." + [path & body] + (compile-route :head path body)) + +(defmacro ANY "Generate a route that matches any method." + [path & body] + (compile-route nil path body)) diff --git a/compojure-3.2/src/compojure/http/servlet.clj b/compojure-3.2/src/compojure/http/servlet.clj new file mode 100755 index 0000000..b6eef26 --- /dev/null +++ b/compojure-3.2/src/compojure/http/servlet.clj @@ -0,0 +1,129 @@ +;; Copyright (c) James Reeves. 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.http.servlet + "Functions for interfacing Compojure with the Java servlet standard." + (:use compojure.http.routes + compojure.http.request) + (:import [java.io File InputStream FileInputStream] + java.util.Map$Entry + [javax.servlet.http Cookie HttpServlet HttpServletRequest HttpServletResponse] + javax.servlet.ServletContext + org.apache.commons.io.IOUtils)) + +;; Functions to pull information from the request object + +(defn- get-headers + "Creates a name/value map of all the request headers." + [#^HttpServletRequest request] + (reduce + (fn [headers name] + (assoc headers (.toLowerCase name) (.getHeader request name))) + {} + (enumeration-seq (.getHeaderNames request)))) + +(defn- get-content-length + "Returns the content length, or nil if there is no content." + [#^HttpServletRequest request] + (let [length (.getContentLength request)] + (if (>= length 0) + length))) + +(defn create-request + "Create the request map from the HttpServletRequest object." + [#^HttpServletRequest request, #^HttpServlet servlet] + {:server-port (.getServerPort request) + :server-name (.getServerName request) + :remote-addr (.getRemoteAddr request) + :uri (.getRequestURI request) + :query-string (.getQueryString request) + :scheme (keyword (.getScheme request)) + :request-method (keyword (.toLowerCase (.getMethod request))) + :headers (get-headers request) + :content-type (.getContentType request) + :content-length (get-content-length request) + :character-encoding (.getCharacterEncoding request) + :body (.getInputStream request) + ;; Custom non-Ring field: + :servlet-request request + :servlet-context (.getServletContext servlet)}) + +;; Functions to set data in the response object + +(defn- set-headers + "Update a HttpServletResponse with a map of headers." + [#^HttpServletResponse response, headers] + (doseq [[key val-or-vals] headers] + (if (string? val-or-vals) + (.setHeader response key val-or-vals) + (doseq [val val-or-vals] + (.addHeader response key val)))) + ; Some headers must be set through specific methods + (when-let [content-type (get headers "Content-Type")] + (.setContentType response content-type))) + +(defn- set-body + "Update a HttpServletResponse body with a String, ISeq, File or InputStream." + [#^HttpServletResponse response, body] + (cond + (string? body) + (with-open [writer (.getWriter response)] + (.println writer body)) + (seq? body) + (with-open [writer (.getWriter response)] + (doseq [chunk body] + (.print writer (str chunk)) + (.flush writer))) + (instance? InputStream body) + (with-open [out (.getOutputStream response)] + (IOUtils/copy body out) + (.close body) + (.flush out)) + (instance? File body) + (with-open [stream (FileInputStream. body)] + (set-body response stream)))) + +(defn update-servlet-response + "Update the HttpServletResponse using a response map." + [#^HttpServletResponse response, {:keys [status headers body]}] + (.setStatus response status) + (set-headers response headers) + (set-body response body)) + +;; Functions that combine request and response handling + +(defn request-handler + "Handle incoming HTTP requests from a servlet." + [[servlet request response] routes] + (.setCharacterEncoding response "UTF-8") + (if-let [response-map (routes (create-request request servlet))] + (update-servlet-response response response-map) + (throw (NullPointerException. + "Handler returned nil (maybe no routes matched URI)")))) + +(definline servlet + "Create a servlet from a sequence of routes. Automatically updates if + the routes binding is redefined." + [routes] + `(proxy [HttpServlet] [] + (~'service [request# response#] + (request-handler [~'this request# response#] + ~routes)))) + +(defmacro defservice + "Defines a service method with an optional prefix suitable for being used by + genclass to compile a HttpServlet class. + e.g. (defservice my-routes) + (defservice \"my-prefix-\" my-routes)" + ([routes] + `(defservice "-" ~routes)) + ([prefix routes] + `(defn ~(symbol (str prefix "service")) + [servlet# request# response#] + (request-handler [servlet# request# response#] + ~routes)))) diff --git a/compojure-3.2/src/compojure/http/session.clj b/compojure-3.2/src/compojure/http/session.clj new file mode 100755 index 0000000..d176dec --- /dev/null +++ b/compojure-3.2/src/compojure/http/session.clj @@ -0,0 +1,243 @@ +;; Copyright (c) James Reeves. 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.http.session + "Functions for creating and updating HTTP sessions." + (:use compojure.str-utils + compojure.http.helpers + compojure.http.request + compojure.http.response + compojure.encodings + compojure.crypto + clojure.contrib.except)) + +;; Override these mulitmethods to create your own session storage. +;; Uses the Compojure repository pattern. + +(defmulti create-session + "Create a new session map. Should not attempt to save the session." + (fn [repository] (:type repository))) + +(defmulti read-session + "Read in the session using the supplied data. Usually the data is a key used + to find the session in a store." + (fn [repository data] (:type repository))) + +(defmulti write-session + "Write a new or existing session to the session store." + (fn [repository session] (:type repository))) + +(defmulti destroy-session + "Remove the session from the session store." + (fn [repository session] (:type repository))) + +(defmulti session-cookie + "Return the session data to be stored in the cookie. This is usually the + session ID." + (fn [repository new? session] (:type repository))) + +;; Default implementations of create-session and set-session-cookie + +(defmethod create-session :default + [repository] + {:id (gen-uuid)}) + +(defmethod session-cookie :default + [repository new? session] + (if new? + (session :id))) + +;; In memory sessions + +(def memory-sessions (ref {})) + +(defmethod read-session :memory + [repository id] + (@memory-sessions id)) + +(defmethod write-session :memory + [repository session] + (dosync + (alter memory-sessions + assoc (session :id) session))) + +(defmethod destroy-session :memory + [repository session] + (dosync + (alter memory-sessions + dissoc (session :id)))) + +;; Cookie sessions + +(def default-session-key + (delay (gen-secret-key {:key-size 128}))) + +(defn- get-session-key + "Get the session key from the repository or use the default key." + [repository] + (force (repository :session-key default-session-key))) + +(defmethod create-session :cookie + [repository] + {}) + +(defmethod session-cookie :cookie + [repository new? session] + (let [session-key (get-session-key repository) + cookie-data (seal session-key session)] + (if (> (count cookie-data) 4000) + (throwf "Session data exceeds 4K") + cookie-data))) + +(defmethod read-session :cookie + [repository data] + (unseal (get-session-key repository) data)) + +(defmethod write-session :cookie + [repository session]) + +(defmethod destroy-session :cookie + [repository session]) + +;; Session middleware + +(defn timestamp-after + "Return the current time plus seconds as milliseconds." + [seconds] + (+ (* seconds 1000) (System/currentTimeMillis))) + +(defn assoc-expiry + "Associate an :expires-at key with the session if the session repository + contains the :expires key." + [repository session] + (if-let [expires (:expires repository)] + (assoc session :expires-at (timestamp-after expires)) + session)) + +(defn session-expired? + "True if this session's timestamp is in the past." + [session] + (if-let [expires-at (:expires-at session)] + (< expires-at (System/currentTimeMillis)))) + +(defn- get-session + "Retrieve the session using the 'session' cookie in the request." + [repository request] + (if-let [session-data (-> request :cookies :compojure-session)] + (read-session repository session-data))) + +(defn- assoc-new-session + "Associate a new session with a request." + [repository request] + (assoc request + :session (assoc-expiry repository (create-session repository)) + :new-session? true)) + +(defn assoc-session + "Associate the session with the request." + [request repository] + (if-let [session (get-session repository request)] + (if (session-expired? session) + (do + (destroy-session repository session) + (assoc-new-session repository request)) + (assoc request :session + (assoc-expiry repository session))) + (assoc-new-session repository request))) + +(defn assoc-flash + "Associate the session flash with the request and remove it from the + session." + [request] + (let [session (:session request)] + (-> request + (assoc :flash (session :flash {})) + (assoc :session (dissoc session :flash))))) + +(defn set-session-cookie + "Set the session cookie on the response if required." + [repository request response session] + (let [new? (:new-session? request) + cookie (session-cookie repository new? session) + update (set-cookie :compojure-session cookie + :path (repository :path "/"))] + (if cookie + (update-response request response update) + response))) + +(defn save-handler-session + "Save the session for a handler if required." + [repository request response session] + (when (and (contains? response :session) + (nil? (response :session))) + (destroy-session repository session)) + (when (or (:session response) + (:new-session? request) + (not-empty (:flash request)) + (contains? repository :expires)) + (write-session repository session))) + +(defn- keyword->repository + "If the argument is a keyword, expand it into a repository map." + [repository] + (if (keyword? repository) + {:type repository} + repository)) + +(defn with-session + "Wrap a handler in a session of the specified type. Session type defaults to + :memory if not supplied." + ([handler] + (with-session handler :memory)) + ([handler repository] + (fn [request] + (let [repo (keyword->repository repository) + request (-> request (assoc-cookies) + (assoc-session repo) + (assoc-flash)) + response (handler request) + session (if (contains? response :session) + (:session response) + (:session request))] + (when response + (save-handler-session repo request response session) + (set-session-cookie repo request response session)))))) + +;; Useful functions for modifying the session + +(defn set-session + "Return a response map with the session set." + [session] + {:session session}) + +(defn clear-session + "Set the session to nil." + [] + (set-session nil)) + +(defn alter-session + "Use a function to alter the session." + [func & args] + (fn [request] + (set-session + (apply func (request :session) args)))) + +(defn session-assoc + "Associate key value pairs with the session." + [& keyvals] + (apply alter-session assoc keyvals)) + +(defn session-dissoc + "Dissociate keys from the session." + [& keys] + (apply alter-session dissoc keys)) + +(defn flash-assoc + "Associate key value pairs with the session flash." + [& keyvals] + (alter-session merge {:flash (apply hash-map keyvals)})) diff --git a/compojure-3.2/src/compojure/map_utils.clj b/compojure-3.2/src/compojure/map_utils.clj new file mode 100755 index 0000000..853c90c --- /dev/null +++ b/compojure-3.2/src/compojure/map_utils.clj @@ -0,0 +1,21 @@ +;; Copyright (c) James Reeves. 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.map-utils + "functions for manipulating maps.") + +(defn assoc-vec + "Associate a key with a value. If the key already exists in the map, create a + vector of values." + [map key val] + (assoc map key + (if-let [cur (map key)] + (if (vector? cur) + (conj cur val) + [cur val]) + val))) diff --git a/compojure-3.2/src/compojure/ns_utils.clj b/compojure-3.2/src/compojure/ns_utils.clj new file mode 100755 index 0000000..5e26ab2 --- /dev/null +++ b/compojure-3.2/src/compojure/ns_utils.clj @@ -0,0 +1,23 @@ +;; Copyright (c) James Reeves. 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.ns-utils) + +(defn immigrate + "Create a public var in this namespace for each public var in the + namespaces named by ns-names. The created vars have the same name, value, + and metadata as the original except that their :ns metadata value is this + namespace." + [& ns-names] + (doseq [ns ns-names] + (require ns) + (doseq [[sym var] (ns-publics ns)] + (let [sym (with-meta sym (assoc (meta var) :ns *ns*))] + (if (.isBound var) + (intern *ns* sym (var-get var)) + (intern *ns* sym)))))) diff --git a/compojure-3.2/src/compojure/server/common.clj b/compojure-3.2/src/compojure/server/common.clj new file mode 100755 index 0000000..b31fbd6 --- /dev/null +++ b/compojure-3.2/src/compojure/server/common.clj @@ -0,0 +1,26 @@ +;; Copyright (c) James Reeves. 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.server.common + "Common functions for implementing compojure server wrapper." + (:import java.net.URL)) + +(defn get-host-and-path + "Splits a path or URL into its hostname and path." + [url-or-path] + (if (re-find #"^[a-z+.-]+://" url-or-path) + (let [url (URL. url-or-path)] + [(.getHost url) (.getPath url)]) + [nil url-or-path])) + +(defn server-with-options + "Create a new server using the supplied function, options and servlets." + [creator options servlets] + (if (map? options) + (creator options servlets) + (creator {} (cons options servlets)))) diff --git a/compojure-3.2/src/compojure/server/grizzly.clj b/compojure-3.2/src/compojure/server/grizzly.clj new file mode 100755 index 0000000..c33a1d5 --- /dev/null +++ b/compojure-3.2/src/compojure/server/grizzly.clj @@ -0,0 +1,74 @@ +;; Copyright (c) James Reeves. 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.server.grizzly + "Clojure interface to start an embedded Grizzly server. To compile, use: + ant -Dwith.grizzly" + (:use compojure.control + compojure.server.common) + (:import javax.servlet.Servlet + com.sun.grizzly.http.embed.GrizzlyWebServer + com.sun.grizzly.http.servlet.ServletAdapter)) + +(defn #^ServletAdapter servlet-adapter + "Wrap a servlet in a ServletAdapter object with a supplied set of parameters + to be set on servlet init." + [#^Servlet servlet & params] + (let [adapter (new ServletAdapter servlet) + params (partition 2 params)] + (doseq [[key val] params] + (.addInitParameter adapter (name key) (str val))) + adapter)) + +(defn add-servlet! + "Add a servlet to a Grizzly server. Servlets can be connected to a relative + path or an absolute URL. Unlike the Jetty server, no Virtual Hosts + are setup." + [#^GrizzlyWebServer server url-or-path servlet] + (let [[host path] (get-host-and-path url-or-path) + #^ServletAdapter adapter (if (instance? ServletAdapter servlet) + servlet + ;; Otherwise, assume it's a servlet. + (let [#^Servlet ss (cast Servlet servlet)] + (ServletAdapter. ss)))] + (.addGrizzlyAdapter server adapter (into-array [path])))) + +(defn- #^GrizzlyWebServer create-server + "Construct a Grizzly Server instance." + [options servlets] + (let [port (options :port 80) + server (GrizzlyWebServer. (int port)) + servlets (partition 2 servlets)] + (doseq [[url-or-path servlet] servlets] + (add-servlet! server url-or-path servlet)) + server)) + +(defn #^GrizzlyWebServer grizzly-server + "Create a new Grizzly HTTP server with the supplied options and servlets." + [options & servlets] + (server-with-options create-server options servlets)) + +(defmacro defserver + "Shortcut for (def name (http-server args))" + [name & args] + `(def ~name (grizzly-server ~@args))) + +(defn start "Start a HTTP server." + [#^GrizzlyWebServer server] + (.start server)) + +(defn stop "Stop a HTTP server." + [#^GrizzlyWebServer server] + (.stop server)) + +(defn run-server + "Create and start a new Grizzly HTTP server." + [& server-args] + (let [#^GrizzlyWebServer server (apply grizzly-server server-args)] + (.start server) + server)) diff --git a/compojure-3.2/src/compojure/server/jetty.clj b/compojure-3.2/src/compojure/server/jetty.clj new file mode 100755 index 0000000..f69d94c --- /dev/null +++ b/compojure-3.2/src/compojure/server/jetty.clj @@ -0,0 +1,106 @@ +;; Copyright (c) James Reeves. 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.server.jetty + "Clojure interface to start an embedded Jetty server." + (:use compojure.control + compojure.server.common) + (:import org.mortbay.jetty.Server + [org.mortbay.jetty.servlet Context ServletHolder] + org.mortbay.jetty.bio.SocketConnector + org.mortbay.jetty.security.SslSocketConnector)) + +(defn servlet-holder + "Wrap a servlet in a ServletHolder object with a supplied set of parameters + to be set on servlet init." + [servlet & params] + (let [holder (new ServletHolder servlet) + params (partition 2 params)] + (doseq [[key val] params] + (.setInitParameter holder (name key) (str val))) + holder)) + +(defn get-context + "Get a Context instance for a server and hostname." + ([server] + (get-context server nil)) + ([server host] + (let [context (Context. server "/" Context/SESSIONS)] + (if host + (doto context (.setVirtualHosts (into-array [host]))) + context)))) + +(decorate-with memoize get-context) + +(defn add-servlet! + "Add a servlet to a Jetty server. Servlets can be connected to a relative + path or an absolute URL. When connected to a URL, the function will try and + use the hostname to set up a virtual host. Wildcards for the domain and path + are allowed." + [server url-or-path servlet] + (prn (class servlet)) + (let [[host path] (get-host-and-path url-or-path) + context (get-context server host) + holder (if (instance? ServletHolder servlet) + servlet + (ServletHolder. servlet))] + (.addServlet context holder path))) + +(defn- add-ssl-connector! + "Add an SslSocketConnector to a Jetty server." + [server options] + (let [ssl-connector (SslSocketConnector.)] + (doto ssl-connector + (.setPort (options :ssl-port 443)) + (.setKeystore (options :keystore)) + (.setKeyPassword (options :key-password))) + (when (options :truststore) + (.setTruststore ssl-connector (options :truststore))) + (when (options :trust-password) + (.setTrustPassword ssl-connector (options :trust-password))) + (.addConnector server ssl-connector))) + +(defn- create-server + "Construct a Jetty Server instance." + [options servlets] + (let [connector (doto (SocketConnector.) + (.setPort (options :port 80)) + (.setHost (options :host))) + server (doto (Server.) + (.addConnector connector)) + servlets (partition 2 servlets)] + (when (or (options :ssl) (options :ssl-port)) + (add-ssl-connector! server options)) + (doseq [[url-or-path servlet] servlets] + (add-servlet! server url-or-path servlet)) + server)) + +(defn jetty-server + "Create a new Jetty HTTP server with the supplied options and servlets." + [options? & servlets] + (server-with-options create-server options? servlets)) + +(defmacro defserver + "Shortcut for (def name (http-server args))" + [name & args] + `(def ~name (jetty-server ~@args))) + +(defn start "Start a HTTP server." + [server] + (.start server)) + +(defn stop "Stop a HTTP server." + [server] + (.stop server)) + +(defn run-server + "Create and start a new Jetty HTTP server." + [& server-args] + (let [server (apply jetty-server server-args)] + (.start server) + server)) diff --git a/compojure-3.2/src/compojure/str_utils.clj b/compojure-3.2/src/compojure/str_utils.clj new file mode 100755 index 0000000..78c6b92 --- /dev/null +++ b/compojure-3.2/src/compojure/str_utils.clj @@ -0,0 +1,86 @@ +;; Copyright (c) James Reeves. 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.str-utils + "Utility functions for manipulating strings." + (:use clojure.contrib.seq-utils + clojure.contrib.str-utils) + (:import clojure.lang.Named)) + +(defn escape + "Returns a string with each occurance of a character in + chars escaped." + [chars #^String string] + (let [charset (set chars)] + (apply str + (mapcat + #(if (contains? charset %) [\\ %] [%]) + string)))) + +(defn map-str + "Map a function to a collection, then concatenate the results into a + string." + [func coll] + (apply str (map func coll))) + +(defn indent + "Indent each line in a string of text. Defaults to an indentation of two + spaces." + ([text] + (indent text " ")) + ([text spacer] + (map-str + #(str spacer % "\n") + (re-split #"\n" text)))) + +(defn str* + "A version of str that prefers the names of Named objects. + e.g (str \"Hello \" :World) => \"Hello :World\" + (str* \"Hello \" :World) => \"Hello World\"" + [& args] + (map-str + #(if (instance? Named %) (name %) (str %)) + args)) + +(defn re-escape + "Escape all special regex chars in string." + [string] + (escape "\\.*+|?()[]{}$^" string)) + +(defn re-groups* + "More consistant re-groups that always returns a vector of groups, even if + there is only one group." + [matcher] + (for [i (range (.groupCount matcher))] + (.group matcher (inc i)))) + +(defn blank? + "True if s = \"\" or nil" + [s] + (or (nil? s) (= s ""))) + +(defn lines + "Concatenate a sequence of strings into lines of a single string." + [coll] + (str-join "\n" coll)) + +(defn capitalize + "Uppercase the first letter of a string, and lowercase the rest." + [s] + (str (.toUpperCase (subs s 0 1)) + (.toLowerCase (subs s 1)))) + +(defn grep + "Filter a collection of strings by a regex." + [re coll] + (filter (partial re-find re) coll)) + +(defn upcase-name + "Upcase a symbol or keyword's name." + [sym] + (. (name sym) toUpperCase)) diff --git a/compojure-3.2/src/compojure/validation.clj b/compojure-3.2/src/compojure/validation.clj new file mode 100755 index 0000000..35e8e32 --- /dev/null +++ b/compojure-3.2/src/compojure/validation.clj @@ -0,0 +1,91 @@ +;; Copyright (c) James Reeves. 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.validation + "Functions for validating form parameters." + (:use compojure.control + compojure.html.form-helpers + compojure.html.page-helpers + clojure.contrib.def)) + +(defvar *errors* {} + "Var containing validation errors.") + +(load "validation/predicates") + +(defn validate + "Validate a single parameter, or group of parameters, using a predicate. If + the predicate fails, a validation error is returned. For a single parameter, + use the following form: + (validate params name pred message) + This will use the value of (pred (params name)) to determine if the parameter + is valid. For multiple parameters: + (validate params pred message) + This will use the value of (pred params) to determine validity." + ([params pred message] + (if (pred params) + {} + {nil [message]})) + ([params name pred message] + (if (pred (params name)) + {} + {name [message]}))) + +(defn merge-errors + "Merge a set of validation errors into a single hash map." + [& results] + (apply merge-with #(into [] (concat %1 %2)) results)) + +(defn validation + "Convinience function to perform a series of validations on a map of params. + Takes a set of params and a collection of argument vectors for the validate + function: + e.g. (validation params + [name pred message] + [pred message]) + Is the same as: + (merge-errors + (validate params name pred message) + (validate params pred message))" + [params & validations] + (apply merge-errors + (map #(apply validate params %) validations))) + +(defn validation-errors? + "True if there are errors in the var *errors*." + [] + (seq *errors*)) + +(defmacro with-validation + "Binds *errors* to (validation-fn *params*)." + [validation-fn & body] + `(binding [*errors* (~validation-fn *params*)] + ~@body)) + +(defmacro with-validated-params + "Equivalent to (with-params params (with-validation validation-fn))." + [params validation-fn & body] + `(with-params ~params + (with-validation ~validation-fn + ~@body))) + +(defn error-summary + "Returns a summary of the errors on the form in HTML." + [] + (unordered-list (apply concat (vals *errors*)))) + +(defn error-class + "Decorator function that marks an input field with an error class if the + parameter has errors." + [func] + (fn [name & args] + (let [errors (*errors* name) + result (apply func name args)] + (if (seq errors) + [:div.error result] + result)))) diff --git a/compojure-3.2/src/compojure/validation/predicates.clj b/compojure-3.2/src/compojure/validation/predicates.clj new file mode 100755 index 0000000..30cda60 --- /dev/null +++ b/compojure-3.2/src/compojure/validation/predicates.clj @@ -0,0 +1,20 @@ +;; Copyright (c) James Reeves. 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.validation.predicates + (:use compojure.str-utils)) + +(defn present? + "True if x is not nil and not an empty string." + [x] + (not (blank? x))) + +(defn max-size + "Returns a function to check a maximum size of a collection." + [n] + #(<= (count %) n)) |