Permalink
Browse files

Merge branch 'cgrand/master'

  • Loading branch information...
mmcgrana committed Apr 29, 2009
2 parents e4a74d5 + b250d14 commit c1bffedb9c7a65e95c24661d96ebab78cb314de6
View
Binary file not shown.
View
Binary file not shown.
View
Binary file not shown.
View
Binary file not shown.
View
@@ -0,0 +1,177 @@
+(ns ring.httpcore
+ (:import (org.apache.http HttpRequest Header HttpEntity HttpEntityEnclosingRequest HttpResponse
+ ConnectionClosedException HttpException HttpServerConnection)
+ (org.apache.http.entity AbstractHttpEntity StringEntity EntityTemplate InputStreamEntity
+ FileEntity ContentProducer)
+ (org.apache.http.message BasicHeader BasicHeaderElement)
+ (org.apache.http.params BasicHttpParams CoreConnectionPNames CoreProtocolPNames)
+ (org.apache.http.protocol HttpRequestHandler BasicHttpContext HttpService BasicHttpProcessor
+ ResponseDate ResponseServer ResponseContent ResponseConnControl HttpRequestHandlerRegistry
+ HttpContext)
+ (org.apache.http.impl DefaultConnectionReuseStrategy DefaultHttpResponseFactory
+ DefaultHttpServerConnection)
+ (java.io File FileInputStream InputStream OutputStream OutputStreamWriter IOException
+ InterruptedIOException)
+ (java.net URI ServerSocket)
+ (java.util.concurrent Executors Executor ThreadFactory))
+ (:use (clojure.contrib fcase except)))
+
+(defmacro #^{:private true} -?>
+ ([form] form)
+ ([form next-form & forms]
+ `(when-let [x# ~form] (-?> (-> x# ~next-form) ~@forms))))
+
+(defmacro #^{:private true} instance?-> [type x & forms]
+ `(when (instance? ~type ~x) (-> ~(vary-meta x assoc :tag type) ~@forms)))
+
+(defn- charset [#^BasicHeader content-type-header]
+ (-?> content-type-header .getElements #^BasicHeaderElement first (.getParameterByName "charset") .getValue))
+
+(defn- lower-case [#^String s]
+ (.toLowerCase s java.util.Locale/ENGLISH))
+
+(defn- build-req-map
+ "Augments the given request-prototype (a map) to represent the given HTTP
+ request, to be passed as the Ring request to an app."
+ [#^HttpRequest request request-prototype]
+ (let [request-line (.getRequestLine request)
+ headers (reduce
+ (fn [header-map #^Header header]
+ (assoc header-map
+ (-> header .getName lower-case)
+ (.getValue header)))
+ {} (seq (.getAllHeaders request)))
+ host (or (headers "host")
+ (str (request-prototype :server-name) ":" (request-prototype :server-port 80)))
+ uri (URI. (str "http://" host (.getUri request-line)))]
+ (into (or request-prototype {})
+ {:server-port (.getPort uri)
+ :server-name (.getHost uri)
+ :uri (.getRawPath uri)
+ :query-string (.getRawQuery uri)
+ :request-method (-> request-line .getMethod lower-case keyword)
+ :headers headers
+ :content-type (headers "content-type")
+ :content-length (when-let [len (instance?-> HttpEntityEnclosingRequest request .getEntity .getContentLength)]
+ (when (>= len 0) len))
+ :character-encoding (instance?-> HttpEntityEnclosingRequest request .getEntity .getContentEncoding charset)
+ :body (instance?-> HttpEntityEnclosingRequest request .getEntity .getContent)})))
+
+(defn- apply-resp-map
+ "Apply the given response map to the servlet response, therby completing
+ the HTTP response."
+ [#^HttpResponse response {:keys [status headers body]}]
+ ; Apply the status.
+ (.setStatusCode response status)
+ ; Apply the 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))))
+ ; Apply the body - the method depends on the given body type.
+ (when body
+ (let [content-type (headers "Content-Type")
+ charset (when content-type (charset (BasicHeader. "Content-Type" content-type)))
+ content-length (headers "Content-Length")
+ entity
+ (cond
+ (string? body)
+ (StringEntity. body)
+ (seq? body)
+ (EntityTemplate.
+ (proxy [ContentProducer] []
+ (writeTo [#^OutputStream s]
+ (let [w (if charset (OutputStreamWriter. s #^String charset) (OutputStreamWriter. s))]
+ (doseq [#^String chunk body]
+ (.write w chunk))
+ (.flush w)))))
+ (instance? InputStream body)
+ (InputStreamEntity. body (let [l (or content-length -1)] (if (>= Long/MAX_VALUE l) l -1)))
+ (instance? File body)
+ (FileEntity. body content-type)
+ :else
+ (throwf "Unrecognized body: %s" body))]
+ (when-let [#^String type (headers "Content-Type")]
+ (.setContentType #^AbstractHttpEntity entity type))
+ (.setEntity response entity))))
+
+(defn- ring-handler
+ "Returns an Handler implementation for the given app.
+ The HttpContext must contains a map associated to \"ring.request-prototype\"."
+ [app]
+ (proxy [HttpRequestHandler] []
+ (handle [request response #^HttpContext context]
+ (let [req (build-req-map request (.getAttribute context "ring.request-prototype"))
+ resp (app req)]
+ (apply-resp-map response resp)))))
+
+
+;; Simple HTTP Server
+
+(defn- handle-request
+ "Handle the request, usually called from a worker thread."
+ [#^HttpService httpservice #^HttpServerConnection conn request-prototype]
+ (let [context (doto (BasicHttpContext. nil)
+ (.setAttribute "ring.request-prototype" request-prototype))]
+ (try
+ (while (.isOpen conn)
+ (.handleRequest httpservice conn context))
+ (catch ConnectionClosedException _ nil)
+ (catch IOException _ nil)
+ (catch HttpException _ nil)
+ (finally
+ (try
+ (.shutdown conn)
+ (catch IOException _ nil))))))
+
+(defn- create-http-service [app]
+ (let [params (doto (BasicHttpParams.)
+ (.setParameter CoreProtocolPNames/ORIGIN_SERVER "HttpComponents/1.1"))
+ httpproc (doto (BasicHttpProcessor.)
+ (.addInterceptor (ResponseDate.))
+ (.addInterceptor (ResponseServer.))
+ (.addInterceptor (ResponseContent.))
+ (.addInterceptor (ResponseConnControl.)))
+ registry (doto (HttpRequestHandlerRegistry.)
+ (.register "*" (ring-handler app)))]
+ (doto (HttpService. httpproc
+ (DefaultConnectionReuseStrategy.)
+ (DefaultHttpResponseFactory.))
+ (.setParams params)
+ (.setHandlerResolver registry))))
+
+(defn executor-execute
+ "Executes (apply f args) using the specified Executor."
+ [#^java.util.concurrent.Executor executor f & args]
+ (.execute executor #(apply f args)))
+
+(defn run
+ "Serve the given app according to the options.
+ Options:
+ :port, an Integer,
+ :server-name, a String -- for old HTTP/1.0 clients,
+ :server-port, an Integer -- for old HTTP/1.0 clients, when public facing port is different from :port,
+ :execute, a function (whose sig is [f & args]) that applies f to args -- usually in another thread."
+ [{:keys [port server-name server-port execute]} app]
+ (let [execute (or execute (partial executor-execute
+ (Executors/newCachedThreadPool
+ (proxy [ThreadFactory] []
+ (newThread [r]
+ (doto (Thread. #^Runnable r)
+ (.setDaemon true)))))))
+ params (doto (BasicHttpParams.)
+ (.setIntParameter CoreConnectionPNames/SO_TIMEOUT 5000)
+ (.setIntParameter CoreConnectionPNames/SOCKET_BUFFER_SIZE (* 8 1024))
+ (.setBooleanParameter CoreConnectionPNames/STALE_CONNECTION_CHECK false)
+ (.setBooleanParameter CoreConnectionPNames/TCP_NODELAY true))
+ httpservice (create-http-service app)
+ request-prototype {:scheme :http :server-port (or server-port port) :server-name server-name}]
+ (with-open [serversocket (ServerSocket. port)]
+ (while (not (.isInterrupted (Thread/currentThread)))
+ (let [socket (.accept serversocket)
+ conn (doto (DefaultHttpServerConnection.)
+ (.bind socket params))]
+ (execute handle-request httpservice conn
+ (assoc request-prototype :remote-addr (-> socket .getInetAddress .getHostAddress))))))))
+

0 comments on commit c1bffed

Please sign in to comment.