com.github.jlangch.venice.ring.venice Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of venice Show documentation
Show all versions of venice Show documentation
Venice, a sandboxed Lisp implemented in Java.
;;;; __ __ _
;;;; \ \ / /__ _ __ (_) ___ ___
;;;; \ \/ / _ \ '_ \| |/ __/ _ \
;;;; \ / __/ | | | | (_| __/
;;;; \/ \___|_| |_|_|\___\___|
;;;;
;;;;
;;;; Copyright 2017-2024 Venice
;;;;
;;;; Licensed under the Apache License, Version 2.0 (the "License");
;;;; you may not use this file except in compliance with the License.
;;;; You may obtain a copy of the License at
;;;;
;;;; http://www.apache.org/licenses/LICENSE-2.0
;;;;
;;;; Unless required by applicable law or agreed to in writing, software
;;;; distributed under the License is distributed on an "AS IS" BASIS,
;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;;; See the License for the specific language governing permissions and
;;;; limitations under the License.
;;;; Venice ring
;;;;
;;;; Venice Ring is a port of Clojure's Ring web applications library
;;;; (https://github.com/ring-clojure/ring).
(ns ring)
(load-module :ring-multipart)
(load-module :ring-mw)
(load-module :ring-session)
(load-module :ring-util)
(import :com.github.jlangch.venice.RingRedirectException
:com.github.jlangch.venice.VncException
:com.github.jlangch.venice.util.servlet.IVeniceServlet
:com.github.jlangch.venice.util.servlet.VeniceServlet
:com.github.jlangch.venice.util.servlet.FilterOutputStreamCloseCB)
(import :jakarta.servlet.http.HttpServletResponse)
(import :jakarta.servlet.http.HttpServletRequest)
;; -----------------------------------------------------------------------------
;; Ring Servlet
;; -----------------------------------------------------------------------------
(defn
^{ :arglists '("(ring/create-servlet handler)")
:doc """
Create a ring servlet.
"""
:see-also '( "ring/match-routes") }
create-servlet [handler]
(. :VeniceServlet :new
(proxify :IVeniceServlet
{ :init (fn [servlet config] (. servlet :log "Initialized"))
:destroy (fn [servlet] (. servlet :log "Destroyed"))
:doGet (fn [servlet req res] (ring/handle req res servlet handler))
:doHead (fn [servlet req res] (ring/handle req res servlet handler))
:doPost (fn [servlet req res] (ring/handle req res servlet handler))
:doPut (fn [servlet req res] (ring/handle req res servlet handler))
:doDelete (fn [servlet req res] (ring/handle req res servlet handler))
:getLastModified (fn [req] -1) })))
;; -----------------------------------------------------------------------------
;; Routing
;; -----------------------------------------------------------------------------
(defn
^{ :arglists '("(ring/match-routes routes)")
:doc """
Compile the routes and return a function that calls the handler
matching the URI.
A route is defined by a HTTP verb, a URI filter and a handle
function. If multiple routes match the route with the longest
URI filter will be chosen.
```
(def routes [
[:get "/**" hello-world-handler]
[:get "/test/**" test-handler]
[:get "/static/images/*.png" image-handler]
[:get "/employees" get-all-employees]
[:get "/employees/:id" get-employee]
[:post "/employees" create-employee]
[:put "/employees/:id" update-employee]
[:delete "/employees/:id" delete-employee] ])
```
Routing URI pattern filters:
* "/**"
* "/app/**"
* "/static/images/chart.png"
* "/static/images/*.png"
* "/static/**/*.png"
A routing handler is single argument function that receives the
request and returns a response.
Handler request:
| [![width: 15%]] | [![width: 85%]] |
| :server-port | The server port. E.g.: 8080 |
| :server-name | The server name. E.g.: localhost |
| :remote-addr | The remote address. E.g.: "0:0:0:0:0:0:0:1" |
| :uri | The request URI. E.g.: "/employees" |
| :query-string | The query string |
| :scheme | The scheme {:http, :https } |
| :request-method | The lower case request method. \
{:get, :post, :put, :delete, :head, :options, \
:trace } |
| :protocol | The protocol. E.g. "HTTP/1.1" |
| :headers | A map of part's headers. Key: header name, \
value: list of header values. The header \
names are mapped to lower case.¶ \
Use `(first ("xxxx" :headers))` to get a \
single value header |
| :parameters | A name/value map of the request parameters |
| :cookies | A map of the cookies. Key: cookie name, \
value: the Java servlet cookie object |
| :content-type | The content type (may be nil) |
| :content-length | The content length |
| :character-encoding | The character encoding |
| :ssl-client-cert | The client certificate, if available |
| :parts | A list of parts, empty for non multipart \
requests |
| :body | The content part as input stream |
Handler response:
```
{ :status 400
:headers { "Content-Type" "text/plain" }
:body "Not a json request!" }
```
The `:body` element of a handler response may be a:
* string
* bytebuf
* :java.io.InputStream
* :java.io.File
Rigging up a Ring WEB App and starting Tomcat:
```
(tc/run-tomcat
(ring/create-servlet (-> (ring/match-routes routes) ; >--+
; |
(ring-mw/mw-dump-request) ; ^ |
(ring-mw/mw-request-counter) ; | |
(ring-mw/mw-add-session 3600) ; | |
(ring-mw/mw-print-uri) ; | |
(ring-mw/mw-debug :on))) ; +--+
{:await? false})
```
"""
:see-also '( "ring/create-servlet") }
match-routes [routes]
(let [compiled (ring/compile-routes routes)]
(fn [req]
(let [verb (:request-method req)
uri (:uri req)
req-params (:parameters req)
route (ring/get-route verb uri compiled)]
(if route
(let [handler (:handler route)
uri-params (zipmap (:uri-param-names route '())
((:uri-param-values route) uri))
params (merge req-params uri-params)
req (assoc req :parameters params)]
(when (ring-util/debug? req)
(println (str "Route: " verb " \"" uri "\" -> " (name handler)))
(println (str "URI parameters: " uri-params)))
(handler req))
(ring-util/not-found-response))))))
;; -----------------------------------------------------------------------------
;; Request handling
;; -----------------------------------------------------------------------------
(defn-
^{ :doc """
Bootstrap the handler chain. Builds the request from then
HttpServletRequest and calls the handler with the request.
Builds the HttpServletResponse from the handler's response.
Sends a not-found HTTP response if the handler returned a
nil response. Sends a redirect if a handler raises a
RingRedirectException. In case of any other exception sends
an internal-error (HTTP status 500) response.
""" }
handle [req res servlet handler]
(try
(if (. req :isAsyncSupported)
(handle-async-request req res servlet handler)
(handle-sync-request req res servlet handler))
(catch :RingRedirectException ex
(ring/send-redirect req res (:redirectUri ex)))
(catch :VncException ex
(. ex :printVeniceStackTrace)
(ring/send-error req res))
(catch :Exception ex
(. ex :printStackTrace)
(ring/send-error req res))))
(defn- handle-sync-request [request response servlet handler]
(handle-request request response servlet handler
{ :async? false }))
(defn- handle-async-request [request response servlet handler]
(let [async-context (. request :startAsync request response)
;; ensure formal type for Tomcat RequestFacade and
;; ResponseFacade. From Tomcat 10+ on these facades
;; implement
;; - jakarta.servlet.http.HttpServletRequest
;; - jakarta.servlet.http.HttpServletResponse
;; instead of javax.servlet.http.*
;; The package 'jakarta.servlet' comes with the
;; Tomcat 10+ core library.
async-request (cast :HttpServletRequest (. async-context :getRequest))
async-response (cast :HttpServletResponse (. async-context :getResponse))]
;; run the request handler asynchronously in its own thread and
;; return immediately
(future (fn [] (try
(handle-request async-request async-response servlet handler
{ :async? true
:async-context async-context
:async-request async-request
:async-response async-response })
(catch :RingRedirectException ex
(ring/send-redirect async-request async-response (:redirectUri ex)))
(catch :VncException ex
(. ex :printVeniceStackTrace)
(ring/send-error async-request async-response))
(catch :Exception ex
(. ex :printStackTrace)
(ring/send-error async-request async-response))
(finally (. async-context :complete)))))))
(defn- handle-request [request response servlet handler request-options]
(let [async? (:async? request-options)
ring-req (-> (ring/build-request-map request)
(merge request-options)
(ring/merge-servlet-keys servlet request response))
;; run the handler chain
ring-res (handler ring-req)]
(if ring-res
(do (when-let [status (:status ring-res)]
(. response :setStatus status))
(ring/set-response-headers response (dissoc (:headers ring-res)))
(ring/write-body-to-stream (:body ring-res)
response
(. response :getOutputStream)))
(when-not async?
;; send a not-found response only when not in async mode
(ring/send-not-found request response)))))
;; -----------------------------------------------------------------------------
;; Request utils
;; -----------------------------------------------------------------------------
(defn
^{ :arglists '(
"(ring/get-header request name)")
:doc """
Returns the multi-value header named 'name'.
Returns `nil` if the header does not exist.
""" }
get-header [request name]
(assert (map? request))
(assert (string? name))
(assert (not-empty? name))
(->> (:headers request)
(seq)
(filter #(str/equals-ignore-case? name (first %)))
(first)
(second)))
;; -----------------------------------------------------------------------------
;; Request/Response utils (internal)
;; -----------------------------------------------------------------------------
(defn-
^{ :arglists '("(ring/set-response-headers response headers)")
:doc "Update a HttpServletResponse with a map of headers." }
set-response-headers [response headers]
(doseq [[k v] headers]
(if (string? v)
(. response :setHeader k v)
(doseq [i v] (. response :setHeader k i))))
; Some headers must be set through specific methods
(if-let [content-type (get headers "Content-Type")]
(. response :setContentType content-type)))
(defn- make-output-stream [response async-context]
(let [os (. response :getOutputStream)]
(if (nil? async-context)
os
(. :FilterOutputStreamCloseCB :new
os
(proxify :Runnable {:run (fn [] (. context :complete))} )))))
(defn- write-body-to-stream [body response output-stream]
(cond
(string? body)
(try-with [os output-stream]
(if-let [charset (ring-util/get-charset response)]
(io/spit-stream os body :flush true :encoding charset)
(io/spit-stream os body :flush true)))
(bytebuf? body)
(try-with [os output-stream]
(io/spit-stream os body :flush true))
(instance-of? :java.io.InputStream body)
(try-with [os output-stream]
(io/copy-stream body os))
(instance-of? :java.io.File body)
(try-with [os output-stream]
(io/copy-file body os))
:else
(throw (ex :VncException
"""
Unsupported response body type '~(type body)'. Use one of \
{string, bytebuf, :java.io.InputStream, :java.io.File}
"""))))
(defn-
^{ :arglists '("(ring/build-request-map request)")
:doc "Create the request map from the HttpServletRequest object." }
build-request-map [request]
(try
(let [content-type (. request :getContentType)
multipart? (ring-multipart/multipart-content-type? content-type)]
(ordered-map
:server-port (. request :getServerPort)
:server-name (. request :getServerName)
:remote-addr (. request :getRemoteAddr)
:uri (. request :getRequestURI)
:query-string (. request :getQueryString)
:scheme (keyword (. request :getScheme))
:request-method (keyword (str/lower-case (. request :getMethod)))
:protocol (. request :getProtocol)
:headers (ring-util/get-headers request)
:parameters (ring-util/get-parameters request)
:cookies (ring-util/get-cookies request)
:content-type content-type
:content-length (ring-util/get-content-length request)
:character-encoding (. request :getCharacterEncoding)
:ssl-client-cert (ring-util/get-client-cert request)
:parts (if multipart? (ring-multipart/map-parts request) '())
:body (. request :getInputStream)))
(catch [:cause-type :java.lang.IllegalStateException] e
(let [e (ex-cause e)]
(if (= (ex-message e) "Unable to process parts as no multi-part configuration has been provided")
(throw (ex :VncException
"""
The servlet is not configured for multi-part!
Please provide a multi-part configuration to the servlet:
{ :name "fileupload-servlet"
:mapping "/upload"
;; multi-part configuration
:file-upload true
:location "/tmp"
:max-file-size 10485760
:max-request-size 10485760
:file-size-threshold -1 }
"""))
(throw e))))))
(defn-
^{ :arglists '("(ring/merge-servlet-keys request-map servlet request response)")
:doc "Associate servlet-specific keys with the request map." }
merge-servlet-keys [request-map servlet request response]
(merge request-map
{:servlet servlet
:servlet-request request
:servlet-response response
:servlet-context (. servlet :getServletContext)
:servlet-path (. request :getServletPath)
:servlet-context-path (. request :getContextPath) }))
;; -----------------------------------------------------------------------------
;; Routing (internal)
;; -----------------------------------------------------------------------------
(defn uri-matches-regex [regex uri]
(regex/matches? (regex/matcher regex uri)))
(defn uri-filter-regex [uri-filter]
;; handles URIs like:
;; "/abc/**/*.png"
;; 1) split: "/abc/" "**" "/" "*" ".png"
;; 2) escape: "\\Q/abc/\\E" "**" "\\Q/\\E" "*" "\\Q.png\\E"
;; 3) translate: "\\Q/abc/\\E" ".*" "\\Q/\\E" "[^/]+" "\\Q.png\\E"
;; 4) join
;; 5) compile pattern
(-<> uri-filter
(str/split <> "((?<=[*]{2})|(?=[*]{2}))")
(map #(if (== "**" %) % (str/split % "((?<=[*])|(?=[*]))")) <>)
(flatten <>)
(map #(if (or (== "**" %) (== "*" %)) % (str "\\Q" % "\\E")) <>)
(map #(if (== "**" %) ".*" %) <>)
(map #(if (== "*" %) "[^/]+" %) <>)
(str/join "" <>)
(regex/pattern <>)))
(defn uri-params-regex [uri-template]
;; handles URIs like:
;; /users/:id
;; /users/:id/playlists/:playlistid
;; 1) mark: "/users/:PARAM/playlists/:PARAM"
;; 1) split: "/users/" ":PARAM" "/playlists/" "*" ":PARAM"
;; 2) escape: "\\Q/users/\\E" ":PARAM" " "\\Q/playlists/\\E" ":PARAM"
;; 3) translate: "\\Q/users/\\E" "([0-9a-zA-Z_]+)" " "\\Q/playlists/\\E" "([0-9a-zA-Z_]+)"
;; 4) join
;; 5) compile pattern
(-<> uri-template
(str/replace-all <> (regex/pattern ":[0-9a-zA-Z_]+") ":PARAM")
(str/split <> "((?<=:PARAM)|(?=:PARAM))")
(map #(if (== ":PARAM" %) % (str/split % "((?<=:PARAM)|(?=:PARAM))")) <>)
(flatten <>)
(map #(if (== ":PARAM" %) "([0-9a-zA-Z_]+)" (str "\\Q" % "\\E")) <>)
(str/join "" <>)
(regex/pattern <>)))
(defn- get-uri-param-names [uri-template]
(-<> (regex/pattern ":[0-9a-zA-Z_]+")
(regex/matcher <> uri-template)
(regex/find-all <>)
(map #(keyword %) <>)))
(defn- get-uri-param-values [uri-regex uri]
(rest (regex/matches uri-regex uri)))
(defn compile-route-filter-uri [route]
{ :verb (first route)
:uri (second route)
:uri-regex (ring/uri-filter-regex (second route))
:uri-param-names '()
:uri-param-values (fn [uri] '())
:len (count (second route))
:handler (third route) })
(defn compile-route-params-uri [route]
(let [regex (ring/uri-params-regex (second route))]
{ :verb (first route)
:uri (second route)
:uri-regex regex
:uri-param-names (ring/get-uri-param-names (second route))
:uri-param-values (fn [uri] (ring/get-uri-param-values regex uri))
:len (count (second route))
:handler (third route) }))
(defn compile-routes [routes]
(map
(fn [route]
(if (str/contains? (second route) ":")
(ring/compile-route-params-uri route)
(ring/compile-route-filter-uri route)))
routes))
(defn- priority-route [routes]
(if (empty? routes)
nil
(last (sort #(compare (:len %1) (:len %2)) routes))))
(defn- get-route [verb uri routes]
(ring/priority-route
(filter (fn [route]
(and (== verb (:verb route))
(ring/uri-matches-regex (:uri-regex route) uri)))
routes)))
;; -----------------------------------------------------------------------------
;; Request/Response functions
;; -----------------------------------------------------------------------------
(defn- accepts-mimetype? [req mimetype]
(str/contains? (. req :getHeader "Accept") mimetype))
(defn- send-redirect [req res redirect-uri]
(. res :sendRedirect (str (. req :getContextPath) redirect-uri)))
(defn- send-not-found [req res]
(. res :setStatus 404)
(let [wr (. res :getWriter)]
(if (accepts-mimetype? req "txt/html")
(do
(. res :setContentType "text/html")
(. res :setCharacterEncoding "UTF-8")
(. wr :println (ring-util/html-box-page
"Not Found"
"The requested webpage was not found!")))
(do
(. res :setContentType "text/plain")
(. res :setCharacterEncoding "UTF-8")
(. wr :println "Not Found\r\n\r\nThe requested webpage was not found!")))))
(defn- send-error [req res]
(. res :setStatus 500)
(let [wr (. res :getWriter)]
(if (accepts-mimetype? req "txt/html")
(do
(. res :setContentType "text/html")
(. res :setCharacterEncoding "UTF-8")
(. wr :println (ring-util/html-box-page
"Internal Error"
"The request processing failed!")))
(do
(. res :setContentType "text/plain")
(. res :setCharacterEncoding "UTF-8")
(. wr :println "Internal Error\r\n\r\nThe request processing failed!")))))