├── .gitignore ├── docs └── img │ └── tfb_json.png ├── src ├── pohjavirta │ ├── ring.clj │ ├── Util.java │ ├── async.clj │ ├── exchange.clj │ ├── server.clj │ ├── websocket.clj │ ├── response.clj │ └── request.clj └── inline │ ├── riddley │ ├── Util.java │ ├── compiler.clj │ └── walk.clj │ └── potemkin │ ├── walk.clj │ ├── macros.clj │ ├── template.clj │ ├── namespaces.clj │ ├── PersistentMapProxy.java │ ├── utils.clj │ ├── collections.clj │ └── types.clj ├── test └── pohjavirta │ ├── websocket_test.clj │ └── server_test.clj ├── pom.xml ├── perf └── pohjavirta │ └── perf_test.clj ├── README.md └── deps.edn /.gitignore: -------------------------------------------------------------------------------- 1 | *.iml 2 | .cpcache 3 | .idea 4 | node_modules 5 | target 6 | out 7 | -------------------------------------------------------------------------------- /docs/img/tfb_json.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metosin/pohjavirta/HEAD/docs/img/tfb_json.png -------------------------------------------------------------------------------- /src/pohjavirta/ring.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.ring) 2 | 3 | (defprotocol RingRequest 4 | (get-server-port [this]) 5 | (get-server-name [this]) 6 | (get-remote-addr [this]) 7 | (get-uri [this]) 8 | (get-query-string [this]) 9 | (get-scheme [this]) 10 | (get-request-method [this]) 11 | (get-protocol [this]) 12 | (get-headers [this]) 13 | (get-header [this header]) 14 | (get-body [this]) 15 | (get-context [this])) 16 | -------------------------------------------------------------------------------- /src/inline/riddley/Util.java: -------------------------------------------------------------------------------- 1 | // Copied and modified from riddley, v0.1.12 (https://github.com/ztellman/riddley), MIT licnensed, Copyright Zachary Tellman 2 | 3 | package inline.riddley; 4 | 5 | import clojure.lang.Symbol; 6 | import clojure.lang.Compiler; 7 | 8 | public class Util { 9 | 10 | public static Compiler.LocalBinding localBinding(int num, Symbol sym, Symbol tag, Object form) { 11 | return new Compiler.LocalBinding(num, sym, tag, Compiler.analyze(Compiler.C.EXPRESSION, form), false, null); 12 | } 13 | 14 | public static Compiler.LocalBinding localArgument(int num, Symbol sym, Symbol tag) { 15 | return new Compiler.LocalBinding(num, sym, tag, null, true, null); 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /src/pohjavirta/Util.java: -------------------------------------------------------------------------------- 1 | package pohjavirta; 2 | 3 | import org.xnio.Buffers; 4 | 5 | import java.nio.ByteBuffer; 6 | 7 | public class Util { 8 | 9 | // From org.projectodd.wunderboss.web.undertow.async.websocket.UndertowWebsocket 10 | public static byte[] toArray(ByteBuffer... payload) { 11 | if (payload.length == 1) { 12 | ByteBuffer buf = payload[0]; 13 | if (buf.hasArray() && buf.arrayOffset() == 0 && buf.position() == 0) { 14 | return buf.array(); 15 | } 16 | } 17 | int size = (int) Buffers.remaining(payload); 18 | byte[] data = new byte[size]; 19 | for (ByteBuffer buf : payload) { 20 | buf.get(data); 21 | } 22 | return data; 23 | } 24 | } 25 | -------------------------------------------------------------------------------- /src/inline/potemkin/walk.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from potemkin, v0.4.3 (https://github.com/ztellman/potemkin), MIT licnensed, Copyright Zachary Tellman 2 | 3 | (ns ^:no-doc inline.potemkin.walk) 4 | 5 | ;; adapted from clojure.walk, but preserves metadata 6 | 7 | (defn walk 8 | "Like `clojure.walk/walk`, but preserves metadata." 9 | [inner outer form] 10 | (let [x (cond 11 | (list? form) (outer (apply list (map inner form))) 12 | (instance? clojure.lang.IMapEntry form) (outer (vec (map inner form))) 13 | (seq? form) (outer (doall (map inner form))) 14 | (coll? form) (outer (into (empty form) (map inner form))) 15 | :else (outer form))] 16 | (if (instance? clojure.lang.IObj x) 17 | (with-meta x (merge (meta form) (meta x))) 18 | x))) 19 | 20 | (defn postwalk 21 | "Like `clojure.walk/postwalk`, but preserves metadata." 22 | [f form] 23 | (walk (partial postwalk f) f form)) 24 | 25 | (defn prewalk 26 | "Like `clojure.walk/prewalk`, but preserves metadata." 27 | [f form] 28 | (walk (partial prewalk f) identity (f form))) 29 | -------------------------------------------------------------------------------- /src/pohjavirta/async.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc pohjavirta.async 2 | (:refer-clojure :exclude [promise]) 3 | (:import (java.util.concurrent CompletableFuture Executor) 4 | (java.util.function Function))) 5 | 6 | (defn promise 7 | ([] 8 | (CompletableFuture.)) 9 | ([x] 10 | (let [cf (CompletableFuture.)] 11 | (.complete cf x) 12 | cf))) 13 | 14 | (defn complete [^CompletableFuture cf x] 15 | (.complete cf x) 16 | cf) 17 | 18 | (defn then [^CompletableFuture cf f] 19 | (.thenApply cf (reify Function 20 | (apply [_ response] 21 | (f response))))) 22 | 23 | (defn then-async 24 | ([^CompletableFuture cf f] 25 | (.thenApplyAsync cf (reify Function 26 | (apply [_ response] 27 | (f response))))) 28 | ([^CompletableFuture cf f ^Executor executor] 29 | (.thenApplyAsync cf (reify Function 30 | (apply [_ response] 31 | (f response))) executor))) 32 | 33 | (defn catch [^CompletableFuture cf f] 34 | (.exceptionally cf (reify Function 35 | (apply [_ exception] 36 | (f exception))))) 37 | -------------------------------------------------------------------------------- /test/pohjavirta/websocket_test.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.websocket-test 2 | (:require [clojure.test :refer :all] 3 | [pohjavirta.websocket :as ws] 4 | [gniazdo.core :as gniazdo] 5 | [pohjavirta.server :as server])) 6 | 7 | (set! *warn-on-reflection* true) 8 | 9 | (defn test-websocket 10 | [] 11 | (let [events (atom []) 12 | errors (atom []) 13 | result (promise) 14 | config {:on-open (fn [_] 15 | (swap! events conj :open)) 16 | :on-message (fn [{:keys [data]}] 17 | (swap! events conj data)) 18 | :on-close (fn [_] 19 | (deliver result (swap! events conj :close))) 20 | :on-error (fn [{:keys [error]}] 21 | (swap! errors conj error))} 22 | handler (ws/ws-handler config) 23 | server (server/create handler)] 24 | (try 25 | (server/start server) 26 | (let [socket (gniazdo/connect "ws://localhost:8080/")] 27 | (gniazdo/send-msg socket "hello") 28 | (gniazdo/close socket)) 29 | (deref result 2000 :fail) 30 | (finally 31 | (server/stop server))))) 32 | 33 | (comment 34 | (test-websocket)) -------------------------------------------------------------------------------- /pom.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 4.0.0 5 | metosin 6 | pohjavirta 7 | 0.0.1-alpha7 8 | pohjavirta 9 | 10 | 11 | io.undertow 12 | undertow-core 13 | 2.2.11.Final 14 | 15 | 16 | 17 | 18 | src 19 | 20 | 21 | src 22 | 23 | 24 | 25 | 26 | 27 | 28 | clojars 29 | https://clojars.org/repo 30 | 31 | 32 | 33 | 34 | 35 | clojars 36 | Clojars repository 37 | https://clojars.org/repo 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /src/inline/potemkin/macros.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from potemkin, v0.4.3 (https://github.com/ztellman/potemkin), MIT licnensed, Copyright Zachary Tellman 2 | 3 | (ns ^:no-doc inline.potemkin.macros 4 | (:require 5 | [inline.potemkin.walk :refer (postwalk)] 6 | [inline.riddley.walk :as r])) 7 | 8 | (defn safe-resolve [x] 9 | (try 10 | (resolve x) 11 | (catch Exception _ 12 | nil))) 13 | 14 | (def unified-gensym-regex #"([a-zA-Z0-9\-\'\*]+)#__\d+__auto__$") 15 | 16 | (def gensym-regex #"(_|[a-zA-Z0-9\-\'\*]+)#?_+(\d+_*#?)+(auto__)?$") 17 | 18 | (defn unified-gensym? [s] 19 | (and 20 | (symbol? s) 21 | (re-find unified-gensym-regex (str s)))) 22 | 23 | (defn gensym? [s] 24 | (and 25 | (symbol? s) 26 | (re-find gensym-regex (str s)))) 27 | 28 | (defn un-gensym [s] 29 | (second (re-find gensym-regex (str s)))) 30 | 31 | (defn unify-gensyms 32 | "All gensyms defined using two hash symbols are unified to the same 33 | value, even if they were defined within different syntax-quote scopes." 34 | [body] 35 | (let [gensym* (memoize gensym)] 36 | (postwalk 37 | #(if (unified-gensym? %) 38 | (symbol (str (gensym* (str (un-gensym %) "__")) "__auto__")) 39 | %) 40 | body))) 41 | 42 | (defn normalize-gensyms 43 | [body] 44 | (let [cnt (atom 0) 45 | gensym* #(str % "__norm__" (swap! cnt inc))] 46 | (postwalk 47 | #(if (gensym? %) 48 | (symbol (gensym* (un-gensym %))) 49 | %) 50 | body))) 51 | 52 | (defn equivalent? 53 | [a b] 54 | (if-not (and a b) 55 | (= a b) 56 | (= 57 | (->> a r/macroexpand-all normalize-gensyms) 58 | (->> b r/macroexpand-all normalize-gensyms)))) 59 | 60 | 61 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /src/inline/riddley/compiler.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from riddley, v0.1.12 (https://github.com/ztellman/riddley), MIT licnensed, Copyright Zachary Tellman 2 | 3 | (ns ^:no-doc inline.riddley.compiler 4 | (:import 5 | [clojure.lang 6 | Var 7 | Compiler 8 | Compiler$ObjMethod 9 | Compiler$ObjExpr] 10 | [inline.riddley 11 | Util])) 12 | 13 | (defn- stub-method [] 14 | (proxy [Compiler$ObjMethod] [(Compiler$ObjExpr. nil) nil])) 15 | 16 | (defn tag-of 17 | "Returns a symbol representing the tagged class of the symbol, or `nil` if none exists." 18 | [x] 19 | (when-let [tag (-> x meta :tag)] 20 | (let [sym (symbol 21 | (if (instance? Class tag) 22 | (.getName ^Class tag) 23 | (name tag)))] 24 | (when-not (= 'java.lang.Object sym) 25 | sym)))) 26 | 27 | (let [n (atom 0)] 28 | (defn- local-id [] 29 | (swap! n inc))) 30 | 31 | (defn locals 32 | "Returns the local binding map, equivalent to the value of `&env`." 33 | [] 34 | (when (.isBound Compiler/LOCAL_ENV) 35 | @Compiler/LOCAL_ENV)) 36 | 37 | (defmacro with-base-env [& body] 38 | `(binding [*warn-on-reflection* false] 39 | (with-bindings (if (locals) 40 | {} 41 | {Compiler/LOCAL_ENV {}}) 42 | ~@body))) 43 | 44 | (defmacro with-lexical-scoping 45 | "Defines a lexical scope where new locals may be registered." 46 | [& body] 47 | `(with-bindings {Compiler/LOCAL_ENV (locals)} 48 | ~@body)) 49 | 50 | (defmacro with-stub-vars [& body] 51 | `(with-bindings {Compiler/CLEAR_SITES nil 52 | Compiler/METHOD (stub-method)} 53 | ~@body)) 54 | 55 | ;; if we don't do this in Java, the checkcasts emitted by Clojure cause an 56 | ;; IllegalAccessError on Compiler$Expr. Whee. 57 | (defn register-local 58 | "Registers a locally bound variable `v`, which is being set to form `x`." 59 | [v x] 60 | (with-stub-vars 61 | (.set ^Var Compiler/LOCAL_ENV 62 | 63 | ;; we want to allow metadata on the symbols to persist, so remove old symbols first 64 | (-> (locals) 65 | (dissoc v) 66 | (assoc v (try 67 | (Util/localBinding (local-id) v (tag-of v) x) 68 | (catch Exception _ 69 | ::analyze-failure))))))) 70 | 71 | (defn register-arg 72 | "Registers a function argument `x`." 73 | [x] 74 | (with-stub-vars 75 | (.set ^Var Compiler/LOCAL_ENV 76 | (-> (locals) 77 | (dissoc x) 78 | (assoc x (Util/localArgument (local-id) x (tag-of x))))))) 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /src/pohjavirta/exchange.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.exchange 2 | (:refer-clojure :exclude [constantly]) 3 | (:require [pohjavirta.request :as request] 4 | [pohjavirta.response :as response]) 5 | (:import (io.undertow.server HttpHandler HttpServerExchange) 6 | (io.undertow.util HttpString) 7 | (pohjavirta.response ResponseSender))) 8 | 9 | (set! *warn-on-reflection* true) 10 | 11 | (defn dispatch [handler] 12 | (fn [request] 13 | (let [exchange ^HttpServerExchange (request/exchange request)] 14 | (if (.isInIoThread exchange) 15 | (.dispatch 16 | exchange 17 | ^Runnable 18 | (^:once fn* [] 19 | (let [result (handler request)] 20 | (response/send-response result exchange) 21 | (when-not (response/async? result) 22 | (.endExchange exchange))))) 23 | (handler request))))) 24 | 25 | (defn constantly 26 | ([handler] 27 | (constantly :ring handler)) 28 | ([mode handler] 29 | (let [{:keys [status headers body]} (handler ::irrelevant) 30 | exchange (gensym) 31 | headers-sym (gensym) 32 | body-sym (gensym) 33 | lets (atom []) 34 | code (cond-> [] 35 | (not (#{200 nil} status)) (conj `(.setStatusCode ~(with-meta exchange {:tag 'io.undertow.server.HttpServerExchange}) ~status)) 36 | (seq headers) (conj 37 | `(let [~headers-sym (.getResponseHeaders ~(with-meta exchange {:tag 'io.undertow.server.HttpServerExchange}))] 38 | ~@(mapv 39 | (fn [[k v]] 40 | (let [k' (gensym)] 41 | (swap! lets conj `[~k' (HttpString/tryFromString ~k)]) 42 | `(.put ~headers-sym ~k' ~v))) headers))) 43 | body (conj (do 44 | (swap! lets conj `[~body-sym (response/direct-byte-buffer ~body)]) 45 | `(.send (.getResponseSender ~(with-meta exchange {:tag 'io.undertow.server.HttpServerExchange})) (.duplicate ~body-sym)))))] 46 | (eval 47 | (case mode 48 | :raw `(let [~@(apply concat @lets)] 49 | (reify HttpHandler 50 | (handleRequest [_ ~exchange] 51 | ~@(if (seq code) code)))) 52 | :ring `(let [~@(apply concat @lets)] 53 | (fn [~'_] 54 | ~@(if (seq code) 55 | `[(reify ResponseSender 56 | (send-response [_ ~exchange] 57 | ~@code))])))))))) 58 | -------------------------------------------------------------------------------- /src/pohjavirta/server.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.server 2 | (:refer-clojure :exclude [constantly]) 3 | (:require [pohjavirta.request :as request] 4 | [pohjavirta.response :as response]) 5 | (:import (io.undertow Undertow UndertowOptions) 6 | (io.undertow.server HttpHandler) 7 | (io.undertow.server.handlers SetHeaderHandler))) 8 | 9 | (set! *warn-on-reflection* true) 10 | 11 | (def default-options 12 | {:port 8080 13 | :host "localhost"}) 14 | 15 | (defn create 16 | ([handler] 17 | (create handler nil)) 18 | ([handler options] 19 | ;; server-options, socket-options, worker-options 20 | ;; :dispatch?, virtual-host, virtual-host 21 | ;; ::ssl-port :keystore, :key-password, :truststore :trust-password, :ssl-context, :key-managers, :trust-managers, :client-auth, :http2? 22 | (let [{:keys [port host buffer-size io-threads worker-threads direct-buffers dispatch ssl-port ssl-context]} (merge default-options options) 23 | handler (cond 24 | (instance? HttpHandler handler) handler 25 | (and (var? handler) (instance? HttpHandler @handler)) @handler 26 | dispatch (reify HttpHandler 27 | (handleRequest [_ exchange] 28 | (.dispatch exchange 29 | ^Runnable (fn [] 30 | (.startBlocking exchange) 31 | (let [request (request/create exchange) 32 | response (handler request)] 33 | (response/send-response response exchange)))))) 34 | :else (reify HttpHandler 35 | (handleRequest [_ exchange] 36 | (let [request (request/create exchange) 37 | response (handler request)] 38 | (response/send-response response exchange)))))] 39 | (assert (not= port ssl-port)) 40 | (-> (Undertow/builder) 41 | (.addHttpListener port host) 42 | (cond-> (and ssl-port ssl-context) 43 | (.addHttpsListener ssl-port host ssl-context)) 44 | (cond-> buffer-size (.setBufferSize buffer-size)) 45 | (cond-> io-threads (.setIoThreads io-threads)) 46 | (cond-> worker-threads (.setWorkerThreads worker-threads)) 47 | (cond-> direct-buffers (.setDirectBuffers direct-buffers)) 48 | (.setServerOption UndertowOptions/ALWAYS_SET_KEEP_ALIVE, false) 49 | (.setServerOption UndertowOptions/BUFFER_PIPELINED_DATA, true) 50 | (.setHandler (SetHeaderHandler. ^HttpHandler handler "Server" "pohjavirta")) 51 | (.build))))) 52 | 53 | (defn start [^Undertow server] 54 | (.start server)) 55 | 56 | (defn stop [^Undertow server] 57 | (.stop server)) 58 | -------------------------------------------------------------------------------- /perf/pohjavirta/perf_test.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.perf-test 2 | (:require [criterium.core :as cc] 3 | [pohjavirta.response :as response] 4 | [pohjavirta.ring :as ring] 5 | [pohjavirta.request :as request]) 6 | (:import (io.undertow.util HttpString) 7 | (java.util Iterator Map$Entry) 8 | (io.undertow.server HttpServerExchange))) 9 | 10 | (defn response-pef [] 11 | 12 | ;; 9ns 13 | (cc/quick-bench 14 | (let [r (response/->Response 200 {"Content-Type" "text/plain"} "hello world 2.0")] 15 | [(:status r) (:headers r) (:body r)])) 16 | 17 | ;; 11ns 18 | #_(cc/quick-bench 19 | (let [r (response/->SimpleResponse 200 "text/plain" "hello world 2.0")] 20 | [(:status r) (:headers r) (:body r)])) 21 | 22 | ;; 20ns 23 | (cc/quick-bench 24 | (let [r {:status 200 25 | :headers {"Content-Type" "text/plain"} 26 | :body "hello 4.0"}] 27 | [(:status r) (:headers r) (:body r)]))) 28 | 29 | (defn http-string-perf [] 30 | 31 | ;; 20ns 32 | (cc/quick-bench 33 | (HttpString. "Content-Type")) 34 | 35 | ;; 5ns 36 | (cc/quick-bench 37 | (HttpString/tryFromString "Content-Type"))) 38 | 39 | (defn reducing-perf [] 40 | 41 | ;;34ns 42 | (cc/quick-bench 43 | (let [headers {"Content-Type" "text/plain"} 44 | m (java.util.HashMap.) 45 | i ^Iterator (.iterator ^Iterable headers)] 46 | (loop [] 47 | (if (.hasNext i) 48 | (let [e ^Map$Entry (.next i)] 49 | (.put m (HttpString/tryFromString ^String (.getKey e)) ^String (.getValue e)) 50 | (recur)))) 51 | m)) 52 | 53 | ;; 60ns 54 | (cc/quick-bench 55 | (let [headers {"Content-Type" "text/plain"} 56 | m (java.util.HashMap.)] 57 | (reduce-kv 58 | (fn [acc k v] 59 | (.put ^java.util.HashMap acc (HttpString/tryFromString ^String k) ^String v) 60 | m) 61 | m 62 | headers)))) 63 | 64 | (declare EXC) 65 | 66 | (defmacro b! [& body] 67 | `(do 68 | (println ~@body) 69 | (cc/quick-bench ~@body))) 70 | 71 | (defn request-mapping-test [] 72 | (let [ex ^HttpServerExchange EXC 73 | r (request/create ex)] 74 | 75 | ;; 70ns 76 | (b! (ring/get-server-port r)) 77 | 78 | ;; 28ns 79 | (b! (ring/get-server-name r)) 80 | 81 | ;; 83ns 82 | (b! (ring/get-remote-addr r)) 83 | 84 | ;; 7ns 85 | (b! (ring/get-uri r)) 86 | 87 | ;; 29ns 88 | (b! (ring/get-query-string r)) 89 | 90 | ;; 19ns 91 | (b! (ring/get-scheme r)) 92 | 93 | ;; 63ns -> 17ns 94 | (b! (ring/get-request-method r)) 95 | 96 | ;; 8ns 97 | (b! (ring/get-protocol r)) 98 | 99 | ;; 2000ns -> 500ns -> 430ns 100 | (b! (ring/get-headers r)) 101 | 102 | ;; 8ns 103 | (b! (ring/get-body r)) 104 | 105 | ;; 8ns 106 | (b! (ring/get-context r)))) 107 | 108 | (comment 109 | (response-pef) 110 | (http-string-perf) 111 | (reducing-perf)) 112 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pohjavirta 2 | 3 | Fast & Non-blocking Clojure wrapper for [Undertow](http://undertow.io/). 4 | 5 | **STATUS:** Pre-alpha, in design and prototyping phase. 6 | 7 | 8 | 9 | ## Latest version 10 | 11 | [![Clojars Project](http://clojars.org/metosin/pohjavirta/latest-version.svg)](http://clojars.org/metosin/pohjavirta) 12 | 13 | ## Usage 14 | 15 | ```clj 16 | (require '[pohjavirta.server :as server]) 17 | (require '[jsonista.core :as j]) 18 | 19 | (defn handler [_] 20 | {:status 200 21 | :headers {"Content-Type" "application/json"} 22 | :body (j/write-value-as-bytes {:message "hello"})}) 23 | 24 | ;; create and start the server 25 | (-> #'handler server/create server/start) 26 | ``` 27 | 28 | By default, the server listens to `localhost` on port `8080`. Trying with [HTTPie](https://httpie.org/): 29 | 30 | ```bash 31 | ➜ ~ http :8080 32 | HTTP/1.1 200 OK 33 | Content-Length: 19 34 | Content-Type: application/json 35 | Date: Sun, 29 Sep 2019 17:50:17 GMT 36 | Server: pohjavirta 37 | 38 | { 39 | "message": "hello" 40 | } 41 | ``` 42 | 43 | Let's run some load with [wrk](https://github.com/wg/wrk): 44 | 45 | ```bash 46 | ➜ ~ wrk -t2 -c16 -d10s http://127.0.0.1:8080 47 | Running 10s test @ http://127.0.0.1:8080 48 | 2 threads and 16 connections 49 | Thread Stats Avg Stdev Max +/- Stdev 50 | Latency 106.47us 52.47us 3.20ms 98.73% 51 | Req/Sec 70.89k 2.49k 75.84k 79.21% 52 | 1424471 requests in 10.10s, 199.70MB read 53 | Requests/sec: 141036.08 54 | Transfer/sec: 19.77MB 55 | ``` 56 | 57 | Async responses, using [promesa](http://funcool.github.io/promesa/latest/): 58 | 59 | ```clj 60 | (require '[promesa.core :as p]) 61 | 62 | (defn handler [_] 63 | (-> (a/promise {:message "async"}) 64 | (a/then (fn [message] 65 | {:status 200, 66 | :headers {"Content-Type" "application/json"} 67 | :body (j/write-value-as-bytes message)})))) 68 | ``` 69 | 70 | We redefined the handler, so no need to restart the server: 71 | 72 | ```bash 73 | ➜ ~ http :8080 74 | HTTP/1.1 200 OK 75 | Content-Length: 19 76 | Content-Type: application/json 77 | Date: Sun, 29 Sep 2019 18:00:35 GMT 78 | Server: pohjavirta 79 | 80 | { 81 | "message": "async" 82 | } 83 | ``` 84 | 85 | Performance is still good: 86 | 87 | ```bash 88 | ➜ ~ wrk -t2 -c16 -d10s http://127.0.0.1:8080 89 | Running 10s test @ http://127.0.0.1:8080 90 | 2 threads and 16 connections 91 | Thread Stats Avg Stdev Max +/- Stdev 92 | Latency 106.86us 33.93us 2.15ms 94.69% 93 | Req/Sec 70.41k 2.38k 78.25k 76.24% 94 | 1414188 requests in 10.10s, 198.26MB read 95 | Requests/sec: 140017.14 96 | Transfer/sec: 19.63MB 97 | ``` 98 | 99 | ## Status 100 | 101 | WIP. See [issues](https://github.com/metosin/pohjavirta/issues) for Roadmap. 102 | 103 | ## License 104 | 105 | Copyright © 2019 [Metosin Oy](http://www.metosin.fi) 106 | 107 | Distributed under the Eclipse Public License, the same as Clojure. 108 | -------------------------------------------------------------------------------- /src/pohjavirta/websocket.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.websocket 2 | (:import [io.undertow.websockets WebSocketConnectionCallback] 3 | [io.undertow.websockets.core AbstractReceiveListener 4 | BufferedBinaryMessage 5 | BufferedTextMessage 6 | CloseMessage 7 | StreamSourceFrameChannel 8 | WebSocketChannel] 9 | [io.undertow.websockets.spi WebSocketHttpExchange] 10 | [io.undertow Handlers] 11 | [org.xnio ChannelListener] 12 | [pohjavirta Util])) 13 | 14 | ;; this may fit better elsewhere. At first start here though to keep modular 15 | 16 | (defn ws-listener 17 | "Default websocket listener 18 | 19 | Takes a map of functions as opts: 20 | :on-message | fn taking map of keys :channel, :data 21 | :on-close-message | fn taking map of keys :channel, :message 22 | :on-close | fn taking map of keys :channel, :ws-channel 23 | :on-error | fn taking map of keys :channel, :error 24 | 25 | Each key defaults to no action" 26 | [{:keys [on-message on-close on-close-message on-error]}] 27 | (let [on-message (or on-message (constantly nil)) 28 | on-error (or on-error (constantly nil)) 29 | on-close-message (or on-close-message (constantly nil)) 30 | on-close (or on-close 31 | (fn [{:keys [ws-channel]}] 32 | (on-close-message {:channel ws-channel 33 | :message (CloseMessage. CloseMessage/GOING_AWAY nil)})))] 34 | (proxy [AbstractReceiveListener] [] 35 | (onFullTextMessage [^WebSocketChannel channel ^BufferedTextMessage message] 36 | (on-message {:channel channel 37 | :data (.getData message)})) 38 | (onFullBinaryMessage [^WebSocketChannel channel ^BufferedBinaryMessage message] 39 | (let [pooled (.getData message)] 40 | (try 41 | (let [payload (.getResource pooled)] 42 | (on-message {:channel channel 43 | :data (Util/toArray payload)})) 44 | (finally (.free pooled))))) 45 | (onClose [^WebSocketChannel websocket-channel ^StreamSourceFrameChannel channel] 46 | (on-close {:channel channel 47 | :ws-channel websocket-channel})) 48 | (onCloseMessage [^CloseMessage message ^WebSocketChannel channel] 49 | (on-close-message {:channel channel 50 | :message message})) 51 | (onError [^WebSocketChannel channel ^Throwable error] 52 | (on-error {:channel channel 53 | :error error}))))) 54 | 55 | (defn ws-callback 56 | [{:keys [on-open listener] 57 | :or {on-open (constantly nil)} 58 | :as ws-opts}] 59 | (let [listener (if (instance? ChannelListener listener) 60 | listener 61 | (ws-listener ws-opts))] 62 | (reify WebSocketConnectionCallback 63 | (^void onConnect [_ ^WebSocketHttpExchange exchange ^WebSocketChannel channel] 64 | (on-open {:channel channel}) 65 | (.set (.getReceiveSetter channel) listener) 66 | (.resumeReceives channel))))) 67 | 68 | (defn ws-handler 69 | "Convenience function to create a basic websocket handler" 70 | [opts] 71 | (Handlers/websocket (ws-callback opts))) -------------------------------------------------------------------------------- /src/inline/potemkin/template.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from potemkin, v0.4.3 (https://github.com/ztellman/potemkin), MIT licnensed, Copyright Zachary Tellman 2 | 3 | (ns ^:no-doc inline.potemkin.template 4 | (:require 5 | [clojure.set :as s] 6 | [inline.riddley.walk :as r] 7 | [inline.riddley.compiler :as c])) 8 | 9 | (defn- validate-body [externs args body] 10 | (let [valid? (atom true) 11 | externs (set externs) 12 | args (set args) 13 | check? (s/union externs args)] 14 | (when-not (empty? (s/intersection externs args)) 15 | (throw 16 | (IllegalArgumentException. 17 | "No overlap allowed between extern and argument names"))) 18 | (r/walk-exprs 19 | symbol? 20 | (fn [s] 21 | (when (and (check? s) (->> (c/locals) keys (filter #(= s %)) first meta ::valid not)) 22 | (throw 23 | (IllegalArgumentException. 24 | (str \' s \' " is shadowed by local lexical binding")))) 25 | (when-not (get (c/locals) s) 26 | (throw 27 | (IllegalArgumentException. 28 | (str \' s \' " is undefined, must be explicitly defined as an extern.")))) 29 | s) 30 | `(let [~@(mapcat 31 | (fn [x] 32 | [(with-meta x {::valid true}) nil]) 33 | (concat 34 | externs 35 | args))] 36 | ~body)) 37 | true)) 38 | 39 | (defn- unquote? [x] 40 | (and (seq? x) (= 'clojure.core/unquote (first x)))) 41 | 42 | (defn- splice? [x] 43 | (and (seq? x) (= 'clojure.core/unquote-splicing (first x)))) 44 | 45 | (defn validate-externs [name externs] 46 | (doseq [e externs] 47 | (when-not (contains? (c/locals) e) 48 | (throw 49 | (IllegalArgumentException. 50 | (str "template " 51 | \' name \' 52 | " expects extern " 53 | \' e \' 54 | " to be defined within local scope.")))))) 55 | 56 | (defmacro deftemplate [name externs args & body] 57 | (let [body `(do ~@body)] 58 | (validate-body externs args body) 59 | (let [arg? (set args) 60 | pred (fn [x] (or (seq? x) (vector? x) (symbol? x)))] 61 | (list 'defmacro name args 62 | (list 'validate-externs (list 'quote name) (list 'quote (set externs))) 63 | (r/walk-exprs 64 | pred 65 | (fn this [x] 66 | (if (or (seq? x) (vector? x)) 67 | (let [splicing? (some splice? x) 68 | terms (map 69 | (fn [t] 70 | (cond 71 | (unquote? t) (second t) 72 | (splice? t) t 73 | :else (r/walk-exprs pred this t))) 74 | x) 75 | x' (if (some splice? x) 76 | (list* 'concat (map #(if (splice? %) (second %) [%]) terms)) 77 | (list* 'list terms))] 78 | (if (vector? x) 79 | (vec x') 80 | x')) 81 | (cond 82 | (arg? x) 83 | x 84 | 85 | (arg? (-> x meta :tag)) 86 | (list 'quote 87 | (list 'with-meta x 88 | (list 'assoc 89 | (list 'meta x) 90 | {:tag (-> x meta :tag)}))) 91 | 92 | :else 93 | (list 'quote x)))) 94 | body))))) 95 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:paths ["src" "resources" "target"] 2 | :aliases {:test {:extra-paths ["test"] 3 | :extra-deps {lambdaisland/kaocha {:mvn/version "0.0-573"} 4 | org.clojure/clojure {:mvn/version "1.10.1"} 5 | stylefruits/gniazdo {:mvn/version "1.1.3"}}} 6 | :jar {:extra-deps {pack/pack.alpha 7 | {:git/url "https://github.com/juxt/pack.alpha.git" 8 | :sha "60cdf0e75efc988b893eafe726ccdf0d5a5a6067"}} 9 | :main-opts ["-m" "mach.pack.alpha.skinny" "--no-libs" 10 | "--project-path" "pohjavirta.jar"]} 11 | :deploy {:extra-deps {deps-deploy {:mvn/version "RELEASE"}} 12 | :main-opts ["-m" "deps-deploy.deps-deploy" "deploy" 13 | "pohjavirta.jar"]} 14 | :install {:extra-deps {deps-deploy {:mvn/version "RELEASE"}} 15 | :main-opts ["-m" "deps-deploy.deps-deploy" "install" 16 | "pohjavirta.jar"]} 17 | :graal {:extra-paths ["perf"] 18 | :extra-deps {criterium {:mvn/version "0.4.5"} 19 | funcool/promesa {:mvn/version "5.0.0"} 20 | metosin/reitit {:mvn/version "0.4.2"} 21 | metosin/porsas {:mvn/version "0.0.1-alpha12"} 22 | metosin/jsonista {:mvn/version "0.2.5"} 23 | hikari-cp {:mvn/version "2.10.0"} 24 | ring {:mvn/version "1.8.0"} 25 | com.clojure-goes-fast/clj-async-profiler {:mvn/version "0.4.0"}} 26 | :jvm-opts ["-server" 27 | "-Xms2G" 28 | "-Xmx2G" 29 | ;"-XX:+UseNUMA" 30 | ;"-XX:+UseParallelGC" 31 | "-Dvertx.disableMetrics=true" 32 | "-Dvertx.threadChecks=false" 33 | "-Dvertx.disableContextTimings=true" 34 | "-Dvertx.disableTCCL=true" 35 | "-Dclojure.compiler.direct-linking=true"]} 36 | :perf {:extra-paths ["perf"] 37 | :extra-deps {criterium {:mvn/version "0.4.5"} 38 | funcool/promesa {:mvn/version "5.0.0"} 39 | metosin/reitit {:mvn/version "0.4.2"} 40 | metosin/porsas {:mvn/version "0.0.1-alpha12"} 41 | metosin/jsonista {:mvn/version "0.2.5"} 42 | hikari-cp {:mvn/version "2.10.0"} 43 | ring {:mvn/version "1.8.0"} 44 | com.clojure-goes-fast/clj-async-profiler {:mvn/version "0.4.0"}} 45 | :jvm-opts ["-server" 46 | "-Xms2G" 47 | "-Xmx2G" 48 | "-XX:+UseNUMA" 49 | "-XX:+UseParallelGC" 50 | "-XX:+AggressiveOpts" 51 | "-Dvertx.disableMetrics=true" 52 | "-Dvertx.threadChecks=false" 53 | "-Dvertx.disableContextTimings=true" 54 | "-Dvertx.disableTCCL=true" 55 | "-Dclojure.compiler.direct-linking=true"]}} 56 | :deps {io.undertow/undertow-core {:mvn/version "2.0.29.Final"}}} 57 | -------------------------------------------------------------------------------- /src/inline/potemkin/namespaces.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from potemkin, v0.4.3 (https://github.com/ztellman/potemkin), MIT licnensed, Copyright Zachary Tellman 2 | 3 | (ns ^:no-doc inline.potemkin.namespaces) 4 | 5 | (defn link-vars 6 | "Makes sure that all changes to `src` are reflected in `dst`." 7 | [src dst] 8 | (add-watch src dst 9 | (fn [_ src old new] 10 | (alter-var-root dst (constantly @src)) 11 | (alter-meta! dst merge (dissoc (meta src) :name))))) 12 | 13 | (defmacro import-fn 14 | "Given a function in another namespace, defines a function with the 15 | same name in the current namespace. Argument lists, doc-strings, 16 | and original line-numbers are preserved." 17 | ([sym] 18 | `(import-fn ~sym nil)) 19 | ([sym name] 20 | (let [vr (resolve sym) 21 | m (meta vr) 22 | n (or name (:name m)) 23 | arglists (:arglists m) 24 | protocol (:protocol m)] 25 | (when-not vr 26 | (throw (IllegalArgumentException. (str "Don't recognize " sym)))) 27 | (when (:macro m) 28 | (throw (IllegalArgumentException. 29 | (str "Calling import-fn on a macro: " sym)))) 30 | 31 | `(do 32 | (def ~(with-meta n {:protocol protocol}) (deref ~vr)) 33 | (alter-meta! (var ~n) merge (dissoc (meta ~vr) :name)) 34 | (link-vars ~vr (var ~n)) 35 | ~vr)))) 36 | 37 | (defmacro import-macro 38 | "Given a macro in another namespace, defines a macro with the same 39 | name in the current namespace. Argument lists, doc-strings, and 40 | original line-numbers are preserved." 41 | ([sym] 42 | `(import-macro ~sym nil)) 43 | ([sym name] 44 | (let [vr (resolve sym) 45 | m (meta vr) 46 | n (or name (with-meta (:name m) {})) 47 | arglists (:arglists m)] 48 | (when-not vr 49 | (throw (IllegalArgumentException. (str "Don't recognize " sym)))) 50 | (when-not (:macro m) 51 | (throw (IllegalArgumentException. 52 | (str "Calling import-macro on a non-macro: " sym)))) 53 | `(do 54 | (def ~n ~(resolve sym)) 55 | (alter-meta! (var ~n) merge (dissoc (meta ~vr) :name)) 56 | (.setMacro (var ~n)) 57 | (link-vars ~vr (var ~n)) 58 | ~vr)))) 59 | 60 | (defmacro import-def 61 | "Given a regular def'd var from another namespace, defined a new var with the 62 | same name in the current namespace." 63 | ([sym] 64 | `(import-def ~sym nil)) 65 | ([sym name] 66 | (let [vr (resolve sym) 67 | m (meta vr) 68 | n (or name (:name m)) 69 | n (with-meta n (if (:dynamic m) {:dynamic true} {})) 70 | nspace (:ns m)] 71 | (when-not vr 72 | (throw (IllegalArgumentException. (str "Don't recognize " sym)))) 73 | `(do 74 | (def ~n @~vr) 75 | (alter-meta! (var ~n) merge (dissoc (meta ~vr) :name)) 76 | (link-vars ~vr (var ~n)) 77 | ~vr)))) 78 | 79 | (defmacro import-vars 80 | "Imports a list of vars from other namespaces." 81 | [& syms] 82 | (let [unravel (fn unravel [x] 83 | (if (sequential? x) 84 | (->> x 85 | rest 86 | (mapcat unravel) 87 | (map 88 | #(symbol 89 | (str (first x) 90 | (when-let [n (namespace %)] 91 | (str "." n))) 92 | (name %)))) 93 | [x])) 94 | syms (mapcat unravel syms)] 95 | `(do 96 | ~@(map 97 | (fn [sym] 98 | (let [vr (resolve sym) 99 | m (meta vr)] 100 | (cond 101 | (:macro m) `(import-macro ~sym) 102 | (:arglists m) `(import-fn ~sym) 103 | :else `(import-def ~sym)))) 104 | syms)))) 105 | -------------------------------------------------------------------------------- /src/inline/potemkin/PersistentMapProxy.java: -------------------------------------------------------------------------------- 1 | // Copied and modified from potemkin, v0.4.3 (https://github.com/ztellman/potemkin), MIT licnensed, Copyright Zachary Tellman 2 | 3 | package inline.potemkin; 4 | 5 | import clojure.lang.*; 6 | import java.util.Iterator; 7 | import java.util.Set; 8 | 9 | public class PersistentMapProxy extends APersistentMap { 10 | 11 | public interface IMap { 12 | Object get(Object k, Object defaultValue); 13 | Set keySet(); 14 | IMap assoc(Object k, Object v); 15 | IMap dissoc(Object k); 16 | IMap empty(); 17 | } 18 | 19 | public interface IEquality { 20 | boolean eq(Object o); 21 | int hash(); 22 | } 23 | 24 | public static class MapEntry extends clojure.lang.MapEntry { 25 | private final Object _key; 26 | private final ILookup _lookup; 27 | 28 | public MapEntry(ILookup lookup, Object key) { 29 | super(key, null); 30 | _key = key; 31 | _lookup = lookup; 32 | } 33 | 34 | @Override 35 | public Object val() { 36 | return _lookup.valAt(_key, null); 37 | } 38 | } 39 | 40 | private final IMap _map; 41 | private final IPersistentMap _meta; 42 | 43 | public PersistentMapProxy(IMap map) { 44 | this._map = map; 45 | this._meta = null; 46 | } 47 | 48 | public PersistentMapProxy(IMap map, IPersistentMap meta) { 49 | this._map = map; 50 | this._meta = meta; 51 | } 52 | 53 | public IMap innerMap() { 54 | return _map; 55 | } 56 | 57 | public IPersistentMap meta() { 58 | return _meta; 59 | } 60 | 61 | public IPersistentMap withMeta(IPersistentMap meta) { 62 | return new PersistentMapProxy(_map, meta); 63 | } 64 | 65 | @Override 66 | public int hashCode() { 67 | return (_map instanceof IEquality) ? ((IEquality)_map).hash() : super.hashCode(); 68 | } 69 | 70 | public boolean equals(Object o) { 71 | if (_map instanceof IEquality) { 72 | IEquality map = (IEquality)_map; 73 | return (o instanceof PersistentMapProxy) ? map.eq(((PersistentMapProxy)o).innerMap()) : map.eq(o); 74 | } 75 | return super.equals(o); 76 | } 77 | 78 | @Override 79 | public boolean containsKey(Object k) { 80 | return _map.keySet().contains(k); 81 | } 82 | 83 | @Override 84 | public IMapEntry entryAt(Object k) { 85 | return containsKey(k) ? new MapEntry(this, k) : null; 86 | } 87 | 88 | @Override 89 | public IPersistentMap assoc(Object k, Object v) { 90 | return new PersistentMapProxy(_map.assoc(k, v)); 91 | } 92 | 93 | @Override 94 | public IPersistentMap assocEx(Object k, Object v) { 95 | if (containsKey(k)) { 96 | throw new IllegalStateException("key already contained in map"); 97 | } 98 | return assoc(k, v); 99 | } 100 | 101 | @Override 102 | public IPersistentMap without(Object k) { 103 | return new PersistentMapProxy(_map.dissoc(k)); 104 | } 105 | 106 | @Override 107 | public Object valAt(Object k) { 108 | return _map.get(k, null); 109 | } 110 | 111 | @Override 112 | public Object valAt(Object k, Object defaultValue) { 113 | return _map.get(k, defaultValue); 114 | } 115 | 116 | @Override 117 | public int count() { 118 | return _map.keySet().size(); 119 | } 120 | 121 | @Override 122 | public IPersistentCollection empty() { 123 | IMap empty = _map.empty(); 124 | return empty != null ? new PersistentMapProxy(_map.empty()) : PersistentHashMap.EMPTY; 125 | } 126 | 127 | @Override 128 | public Iterator iterator() { 129 | final Iterator i = _map.keySet().iterator(); 130 | final ILookup l = this; 131 | return new Iterator() { 132 | 133 | @Override 134 | public boolean hasNext() { 135 | return i.hasNext(); 136 | } 137 | 138 | @Override 139 | public Object next() { 140 | Object k = i.next(); 141 | return new clojure.lang.MapEntry(k, l.valAt(k, null)); 142 | } 143 | 144 | @Override 145 | public void remove() { 146 | throw new UnsupportedOperationException(); 147 | } 148 | }; 149 | } 150 | 151 | @Override 152 | public ISeq seq() { 153 | return IteratorSeq.create(iterator()); 154 | } 155 | } 156 | -------------------------------------------------------------------------------- /src/inline/potemkin/utils.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from potemkin, v0.4.3 (https://github.com/ztellman/potemkin), MIT licnensed, Copyright Zachary Tellman 2 | ;; Changes: 3 | ;; - removed fast-memoize and friends to remove need for clj-tuple 4 | 5 | (ns ^:no-doc inline.potemkin.utils 6 | (:require 7 | [inline.potemkin.macros :refer [unify-gensyms]]) 8 | (:import 9 | [java.util.concurrent 10 | ConcurrentHashMap])) 11 | 12 | (defmacro fast-bound-fn 13 | "Creates a variant of bound-fn which doesn't assume you want a merged 14 | context between the source and execution environments." 15 | [& fn-body] 16 | (let [{:keys [major minor]} *clojure-version* 17 | use-thread-bindings? (and (= 1 major) (< minor 3)) 18 | use-get-binding? (and (= 1 major) (< minor 4))] 19 | (if use-thread-bindings? 20 | `(let [bindings# (get-thread-bindings) 21 | f# (fn ~@fn-body)] 22 | (fn [~'& args#] 23 | (with-bindings bindings# 24 | (apply f# args#)))) 25 | `(let [bound-frame# ~(if use-get-binding? 26 | `(clojure.lang.Var/getThreadBindingFrame) 27 | `(clojure.lang.Var/cloneThreadBindingFrame)) 28 | f# (fn ~@fn-body)] 29 | (fn [~'& args#] 30 | (let [curr-frame# (clojure.lang.Var/getThreadBindingFrame)] 31 | (clojure.lang.Var/resetThreadBindingFrame bound-frame#) 32 | (try 33 | (apply f# args#) 34 | (finally 35 | (clojure.lang.Var/resetThreadBindingFrame curr-frame#))))))))) 36 | 37 | (defn fast-bound-fn* 38 | "Creates a function which conveys bindings, via fast-bound-fn." 39 | [f] 40 | (fast-bound-fn [& args] 41 | (apply f args))) 42 | 43 | (defn retry-exception? [x] 44 | (= "clojure.lang.LockingTransaction$RetryEx" (.getName ^Class (class x)))) 45 | 46 | (defmacro try* 47 | "A variant of try that is fully transparent to transaction retry exceptions" 48 | [& body+catch] 49 | (let [body (take-while 50 | #(or (not (sequential? %)) (not (= 'catch (first %)))) 51 | body+catch) 52 | catch (drop (count body) body+catch) 53 | ignore-retry (fn [x] 54 | (when x 55 | (let [ex (nth x 2)] 56 | `(~@(take 3 x) 57 | (if (inline.potemkin.utils/retry-exception? ~ex) 58 | (throw ~ex) 59 | (do ~@(drop 3 x))))))) 60 | class->clause (-> (zipmap (map second catch) catch) 61 | (update-in ['Throwable] ignore-retry) 62 | (update-in ['Error] ignore-retry))] 63 | `(try 64 | ~@body 65 | ~@(->> class->clause vals (remove nil?))))) 66 | 67 | (defmacro condp-case 68 | "A variant of condp which has case-like syntax for options. When comparing 69 | smaller numbers of keywords, this can be faster, sometimes significantly." 70 | [predicate value & cases] 71 | (unify-gensyms 72 | `(let [val## ~value 73 | pred## ~predicate] 74 | (cond 75 | ~@(->> cases 76 | (partition 2) 77 | (map 78 | (fn [[vals expr]] 79 | `(~(if (sequential? vals) 80 | `(or ~@(map (fn [x] `(pred## val## ~x)) vals)) 81 | `(pred## val## ~vals)) 82 | ~expr))) 83 | (apply concat)) 84 | :else 85 | ~(if (even? (count cases)) 86 | `(throw (IllegalArgumentException. (str "no matching clause for " (pr-str val##)))) 87 | (last cases)))))) 88 | 89 | (defmacro doit 90 | "A version of doseq that doesn't emit all that inline-destroying chunked-seq code." 91 | [[x it] & body] 92 | (let [it-sym (gensym "iterable")] 93 | `(let [~it-sym ~it 94 | it# (.iterator ~(with-meta it-sym {:tag "Iterable"}))] 95 | (loop [] 96 | (when (.hasNext it#) 97 | (let [~x (.next it#)] 98 | ~@body) 99 | (recur)))))) 100 | 101 | (defmacro doary 102 | "An array-specific version of doseq." 103 | [[x ary] & body] 104 | (let [ary-sym (gensym "ary")] 105 | `(let [~(with-meta ary-sym {:tag "objects"}) ~ary] 106 | (dotimes [idx# (alength ~ary-sym)] 107 | (let [~x (aget ~ary-sym idx#)] 108 | ~@body))))) 109 | -------------------------------------------------------------------------------- /src/pohjavirta/response.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.response 2 | (:require [clojure.java.io :as io]) 3 | (:import (io.undertow.io IoCallback) 4 | (io.undertow.server HttpServerExchange) 5 | (io.undertow.util HeaderMap HttpString SameThreadExecutor) 6 | (java.io File InputStream) 7 | (java.nio ByteBuffer) 8 | (java.nio.channels FileChannel) 9 | (java.nio.file OpenOption) 10 | (java.util Iterator Map$Entry Collection) 11 | (java.util.concurrent CompletionStage) 12 | (java.util.function Function))) 13 | 14 | (set! *warn-on-reflection* true) 15 | 16 | (defrecord Response [status headers body]) 17 | 18 | (defprotocol ResponseSender 19 | (async? [this]) 20 | (send-response [this exchange])) 21 | 22 | (defprotocol BodySender 23 | (send-body [this exchange])) 24 | 25 | (defn ^:no-doc ^ByteBuffer direct-byte-buffer [x] 26 | (cond 27 | (string? x) (recur (.getBytes ^String x "UTF-8")) 28 | (bytes? x) (.flip (.put (ByteBuffer/allocateDirect (alength ^bytes x)) ^bytes x)) 29 | (instance? ByteBuffer x) x 30 | :else (throw (UnsupportedOperationException. (str "invalid type " (class x) ": " x))))) 31 | 32 | (defn- -send-map-like-response [response ^HttpServerExchange exchange] 33 | (when-let [status (:status response)] 34 | (.setStatusCode ^HttpServerExchange exchange status)) 35 | (when-let [headers (:headers response)] 36 | (let [responseHeaders ^HeaderMap (.getResponseHeaders exchange) 37 | i ^Iterator (.iterator ^Iterable headers)] 38 | (loop [] 39 | (if (.hasNext i) 40 | (let [e ^Map$Entry (.next i) 41 | v (.getValue e)] 42 | (if (coll? v) 43 | (.putAll responseHeaders (HttpString/tryFromString ^String (.getKey e)) ^Collection v) 44 | (.put responseHeaders (HttpString/tryFromString ^String (.getKey e)) ^String v)) 45 | (recur)))))) 46 | (send-body (:body response) exchange)) 47 | 48 | (extend-protocol ResponseSender 49 | 50 | HttpServerExchange 51 | (async? [_] false) 52 | (send-response [_ _]) 53 | 54 | CompletionStage 55 | (async? [_] true) 56 | (send-response [response exchange] 57 | (.dispatch 58 | ^HttpServerExchange exchange 59 | SameThreadExecutor/INSTANCE 60 | ^Runnable (^:once fn* [] 61 | (.thenApply 62 | response 63 | ^Function (reify Function 64 | (apply [_ response] 65 | (send-response response exchange) 66 | (.endExchange ^HttpServerExchange exchange))))))) 67 | 68 | clojure.lang.PersistentArrayMap 69 | (async? [_] false) 70 | (send-response [response exchange] 71 | (-send-map-like-response response exchange)) 72 | 73 | clojure.lang.PersistentHashMap 74 | (async? [_] false) 75 | (send-response [response exchange] 76 | (-send-map-like-response response exchange)) 77 | 78 | Response 79 | (async? [_] false) 80 | (send-response [response exchange] 81 | (-send-map-like-response response exchange)) 82 | 83 | nil 84 | (async? [_] false) 85 | (send-response [_ exchange] 86 | (.endExchange ^HttpServerExchange exchange))) 87 | 88 | (extend-protocol BodySender 89 | 90 | (Class/forName "[B") 91 | (send-body [body exchange] 92 | (-> ^HttpServerExchange exchange 93 | (.getResponseSender) 94 | (.send (ByteBuffer/wrap body)))) 95 | 96 | String 97 | (send-body [body exchange] 98 | (-> ^HttpServerExchange exchange 99 | (.getResponseSender) 100 | (.send ^String body))) 101 | 102 | ByteBuffer 103 | (send-body [body exchange] 104 | (-> ^HttpServerExchange exchange 105 | (.getResponseSender) 106 | (.send ^ByteBuffer body))) 107 | 108 | InputStream 109 | (send-body [stream ^HttpServerExchange exchange] 110 | (if (.isInIoThread exchange) 111 | (.dispatch exchange ^Runnable (fn [] 112 | (send-body stream exchange))) 113 | (with-open [stream stream] 114 | (.startBlocking exchange) 115 | (io/copy stream (.getOutputStream exchange)) 116 | (.endExchange exchange)))) 117 | 118 | File 119 | (send-body [file ^HttpServerExchange exchange] 120 | (send-body (io/input-stream file) exchange) 121 | #_(if (.isInIoThread exchange) 122 | (.dispatch exchange ^Runnable (fn [] (send-body file exchange))) 123 | (let [channel ^FileChannel (FileChannel/open (.toPath file) (into-array OpenOption [])) 124 | sender (.getResponseSender exchange)] 125 | (.transferFrom 126 | sender 127 | channel 128 | ^IoCallback 129 | (reify 130 | IoCallback 131 | (onComplete [_ _ _] 132 | (.close channel) 133 | (.endExchange exchange)) 134 | (onException [_ _ _ exception] 135 | (.close channel) 136 | (.onException IoCallback/END_EXCHANGE exchange sender ^Exception exception))))))) 137 | 138 | Object 139 | (send-body [body _] 140 | (throw (UnsupportedOperationException. (str "Body class not supported: " (class body))))) 141 | 142 | nil 143 | (send-body [_ ^HttpServerExchange exchange] 144 | (.endExchange exchange))) 145 | -------------------------------------------------------------------------------- /src/pohjavirta/request.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.request 2 | (:require [inline.potemkin.collections :as fpc] 3 | [clojure.string :as str] 4 | [pohjavirta.ring :as ring]) 5 | (:import (java.util HashMap Collections Map Map$Entry) 6 | (io.undertow.util HttpString HeaderValues HeaderMap Headers) 7 | (java.lang.reflect Field) 8 | (io.undertow.server HttpServerExchange) 9 | (clojure.lang MapEquivalence IPersistentMap Counted IPersistentCollection IPersistentVector ILookup IFn IObj Seqable Reversible SeqIterator Associative IHashEq MapEntry))) 10 | 11 | (set! *warn-on-reflection* true) 12 | 13 | (def ^Map request-headers 14 | (let [headers (HashMap.)] 15 | (doseq [^String m (->> Headers 16 | .getDeclaredFields 17 | (filter #(= HttpString (.getType ^Field %))) 18 | (map #(.getName ^Field %)))] 19 | (.put headers (HttpString. m) (.toLowerCase m))) 20 | (Collections/unmodifiableMap headers))) 21 | 22 | (defn ->header [^HttpString header-http-string] 23 | (or (.get request-headers header-http-string) 24 | (-> header-http-string .toString .toLowerCase))) 25 | 26 | (defn ->headers [^HeaderMap header-map] 27 | (let [it (.iterator header-map)] 28 | (loop [m {}] 29 | (if (.hasNext it) 30 | (let [hvs ^HeaderValues (.next it) 31 | hk (-> hvs .getHeaderName ->header) 32 | hv (if (= 1 (.size hvs)) (.getFirst hvs) (str/join "," hvs))] 33 | (recur (assoc m hk hv))) 34 | m)))) 35 | 36 | (fpc/def-derived-map ZeroCopyRequest [^HttpServerExchange exchange] 37 | :server-port (-> exchange .getDestinationAddress .getPort) 38 | :server-name (.getHostName exchange) 39 | :remote-addr (-> exchange .getSourceAddress .getAddress .getHostAddress) 40 | :uri (.getRequestURI exchange) 41 | :query-string (let [qs (.getQueryString exchange)] (if-not (.equals "" qs) qs)) 42 | :scheme (-> exchange .getRequestScheme keyword) 43 | :request-method (-> exchange .getRequestMethod .toString .toLowerCase keyword) 44 | :protocol (-> exchange .getProtocol .toString) 45 | :headers (-> exchange .getRequestHeaders ->headers) 46 | :body (if (.isBlocking exchange) (.getInputStream exchange)) 47 | :context (.getResolvedPath exchange)) 48 | 49 | (defprotocol Exchange 50 | (^HttpServerExchange exchange [this])) 51 | 52 | ;; 53 | ;; PartialCopyRequest 54 | ;; 55 | 56 | (deftype PartialCopyRequest [drec dmap] 57 | Exchange 58 | (exchange [_] (exchange dmap)) 59 | 60 | ring/RingRequest 61 | (get-server-port [this] (:server-port this)) 62 | (get-server-name [this] (:server-name this)) 63 | (get-remote-addr [this] (:remote-addr this)) 64 | (get-uri [_this] (:uri drec)) 65 | (get-query-string [this] (:query-string this)) 66 | (get-scheme [this] (:schema this)) 67 | (get-request-method [_this] (:request-method drec)) 68 | (get-protocol [this] (:protocol this)) 69 | (get-headers [this] (:headers this)) 70 | (get-header [this header] (get (:headers this) header)) 71 | (get-body [this] (:body this)) 72 | (get-context [this] (:context this)) 73 | 74 | IPersistentMap 75 | (assoc [_ k v] 76 | (PartialCopyRequest. (assoc drec k v) dmap)) 77 | (assocEx [this k v] 78 | (if (.containsKey this k) 79 | (throw (RuntimeException. "Key already present")) 80 | (assoc this k v))) 81 | (without [_ k] 82 | (PartialCopyRequest. (dissoc drec k) (dissoc dmap k))) 83 | 84 | MapEquivalence 85 | 86 | Map 87 | (get [this k] 88 | (.valAt this k)) 89 | (isEmpty [this] 90 | (not (.seq this))) 91 | (entrySet [this] 92 | (set (or (.seq this) []))) 93 | (containsValue [this v] 94 | (boolean (seq (filter #(= % v) (.values this))))) 95 | (values [this] 96 | (map val (.seq this))) 97 | (size [this] 98 | (count (.seq this))) 99 | 100 | Counted 101 | 102 | IPersistentCollection 103 | (count [this] 104 | (.size this)) 105 | (cons [this o] 106 | (condp instance? o 107 | Map$Entry (let [^Map$Entry e o] 108 | (.assoc this (.getKey e) (.getValue e))) 109 | IPersistentVector (if (= 2 (count o)) 110 | (.assoc this (nth o 0) (nth o 1)) 111 | (throw (IllegalArgumentException. "Vector arg to map conj must be a pair"))) 112 | (reduce 113 | (fn [^IPersistentMap m ^Map$Entry e] 114 | (.assoc m (.getKey e) (.getValue e))) 115 | this o))) 116 | (empty [_] 117 | (PartialCopyRequest. (empty drec) (empty dmap))) 118 | (equiv [this o] 119 | (and (instance? Map o) 120 | (= (.count this) (count o)) 121 | (every? (fn [[k v :as kv]] 122 | (= kv (find o k))) 123 | (.seq this)))) 124 | 125 | Seqable 126 | (seq [_] 127 | (seq (into {} (concat (seq dmap) (seq drec))))) 128 | 129 | Reversible 130 | (rseq [this] 131 | (reverse (seq this))) 132 | 133 | Iterable 134 | (iterator [this] 135 | (SeqIterator. (.seq this))) 136 | 137 | Associative 138 | (containsKey [_ k] 139 | (or (contains? drec k) (contains? dmap k))) 140 | (entryAt [this k] 141 | (when (.containsKey this k) 142 | (MapEntry. k (.valAt this k)))) 143 | 144 | ILookup 145 | (valAt [_ k] 146 | (or (.valAt ^ILookup drec k nil) (.get ^Map dmap k))) 147 | (valAt [_ k not-found] 148 | (if-let [entry (or (find drec k) (find dmap k))] 149 | (val entry) 150 | not-found)) 151 | 152 | IFn 153 | (invoke [this k] 154 | (.valAt this k)) 155 | (invoke [this k not-found] 156 | (.valAt this k not-found)) 157 | 158 | IObj 159 | (meta [_] 160 | (.meta ^IObj drec)) 161 | (withMeta [_ m] 162 | (PartialCopyRequest. (.withMeta ^IObj drec m) dmap)) 163 | 164 | IHashEq 165 | (hasheq [this] (.hasheq ^IHashEq (into {} this))) 166 | 167 | Object 168 | (toString [this] 169 | (str "{" (str/join ", " (for [[k v] this] (str k " " v))) "}")) 170 | (equals [this other] 171 | (.equiv this other)) 172 | (hashCode [this] 173 | (.hashCode ^Object (into {} this)))) 174 | 175 | (defmethod print-method PartialCopyRequest [^PartialCopyRequest o ^java.io.Writer w] 176 | (.write w "#PartialCopyRequest") 177 | (.write w (pr-str (into {} (seq o))))) 178 | 179 | (extend-protocol Exchange 180 | ZeroCopyRequest 181 | (exchange [this] (.exchange this))) 182 | 183 | (defmethod print-method ZeroCopyRequest [request ^java.io.Writer w] 184 | (let [exchange ^HttpServerExchange (exchange request) 185 | data (if exchange {:xnio (.isInIoThread exchange) 186 | :blocking (.isBlocking exchange)} {})] 187 | (.write w (str "#ZeroCopyRequest" data)))) 188 | 189 | (defrecord Request [uri request-method]) 190 | 191 | ;; 192 | ;; public api 193 | ;; 194 | 195 | (defn create 196 | "Creates a partial-copy request where the commonly needed 197 | keys are copied to an internal [[Request]] Record, while 198 | rest of the keys are handled via [[ZeroCopyRequest]]." 199 | [^HttpServerExchange exchange] 200 | (->PartialCopyRequest 201 | ;; eager copy 202 | (->Request 203 | (.getRequestURI exchange) 204 | (-> exchange .getRequestMethod .toString .toLowerCase keyword)) 205 | ;; realize on access 206 | (->ZeroCopyRequest exchange))) 207 | -------------------------------------------------------------------------------- /test/pohjavirta/server_test.clj: -------------------------------------------------------------------------------- 1 | (ns pohjavirta.server-test 2 | (:require [clojure.test :refer :all] 3 | [pohjavirta.server :as server] 4 | [pohjavirta.response :as response] 5 | [pohjavirta.exchange :as exchange] 6 | [pohjavirta.async :as a] 7 | [hikari-cp.core :as hikari] 8 | [ring.adapter.jetty :as jetty]) 9 | (:import (java.nio ByteBuffer) 10 | (java.util.concurrent CompletableFuture) 11 | (io.undertow.server HttpHandler HttpServerExchange) 12 | (io.undertow.util Headers) 13 | (java.util.concurrent ThreadLocalRandom) 14 | (java.util.function Function Supplier) 15 | (clojure.lang IDeref))) 16 | 17 | (set! *warn-on-reflection* true) 18 | 19 | (def http-handler 20 | (let [bytes (.getBytes "Hello, World!") 21 | buffer (-> bytes count ByteBuffer/allocateDirect (.put bytes) .flip)] 22 | (reify HttpHandler 23 | (handleRequest [_ exchange] 24 | (-> exchange 25 | (.getResponseHeaders) 26 | (.put Headers/CONTENT_TYPE "text/plain")) 27 | (-> exchange 28 | (.getResponseSender) 29 | (.send (.duplicate ^ByteBuffer buffer))))))) 30 | 31 | (defn handler [_] 32 | {:status 200 33 | :headers {"Content-Type" "text/plain"} 34 | :body "hello World!"}) 35 | 36 | (defn handler [_] 37 | (response/->Response 200 {"Content-Type" "text/plain"} "hello World?")) 38 | 39 | (defn handler [_] 40 | (let [f (CompletableFuture.)] 41 | (future (.complete f {:status 200 42 | :headers {"Content-Type" "text/plain"} 43 | :body "hello Future!"})) 44 | f)) 45 | 46 | (require '[promesa.core :as p]) 47 | (require '[porsas.async :as pa]) 48 | (require '[porsas.core :as ps]) 49 | (require '[jsonista.core :as j]) 50 | 51 | (def async-pool 52 | (pa/pool 53 | {:uri "postgresql://localhost:5432/hello_world" 54 | :user "benchmarkdbuser" 55 | :password "benchmarkdbpass" 56 | :size (* 2 (.availableProcessors (Runtime/getRuntime)))})) 57 | 58 | (def async-mapper (pa/data-mapper {:row (pa/rs->compiled-record)})) 59 | 60 | (def jdbc-pool 61 | (hikari/make-datasource 62 | {:jdbc-url "jdbc:postgresql://localhost:5432/hello_world" 63 | :username "benchmarkdbuser" 64 | :password "benchmarkdbpass" 65 | :maximum-pool-size 256})) 66 | 67 | (def jdbc-mapper (ps/data-mapper {:row (ps/rs->compiled-record)})) 68 | 69 | (defn random [] 70 | (unchecked-inc (.nextInt (ThreadLocalRandom/current) 10000))) 71 | 72 | (defn sync-db-handler [_] 73 | (let [world (with-open [con (ps/get-connection jdbc-pool)] 74 | (ps/query-one jdbc-mapper con ["SELECT id, randomnumber from WORLD where id=?" (random)]))] 75 | {:status 200 76 | :headers {"Content-Type" "application/json"} 77 | :body (j/write-value-as-bytes world)})) 78 | 79 | (def http-handler 80 | (reify HttpHandler 81 | (handleRequest [_ exchange] 82 | #_(.startBlocking exchange) 83 | (.dispatch 84 | ^HttpServerExchange exchange 85 | ^Runnable (^:once fn* [] 86 | (let [world (with-open [con (ps/get-connection jdbc-pool)] 87 | (ps/query-one jdbc-mapper con ["SELECT id, randomnumber from WORLD where id=?" (random)]))] 88 | (response/send-response 89 | {:status 200 90 | :headers {"Content-Type" "application/json"} 91 | :body (j/write-value-as-bytes world)} 92 | exchange))))))) 93 | 94 | (def http-handler 95 | (reify HttpHandler 96 | (handleRequest [_ exchange] 97 | #_(.startBlocking exchange) 98 | (.dispatch 99 | ^HttpServerExchange exchange 100 | ;SameThreadExecutor/INSTANCE 101 | ^Runnable (^:once fn* [] 102 | (-> (pa/query-one async-mapper async-pool ["SELECT id, randomnumber from WORLD where id=$1" (random)]) 103 | (pa/then (fn [world] 104 | {:status 200 105 | :headers {"Content-Type" "application/json"} 106 | :body (j/write-value-as-bytes world)})))))))) 107 | 108 | (def http-handler 109 | (reify HttpHandler 110 | (handleRequest [_ exchange] 111 | (-> (pa/query-one async-mapper async-pool ["SELECT id, randomnumber from WORLD where id=$1" (random)]) 112 | (pa/then (fn [world] 113 | (response/send-response 114 | {:status 200 115 | :headers {"Content-Type" "application/json"} 116 | :body (j/write-value-as-bytes world)} 117 | exchange) 118 | (.endExchange ^HttpServerExchange exchange))))))) 119 | 120 | (defn handler [_] 121 | (-> (a/promise "Hello, Async?") 122 | (a/then (fn [response] 123 | {:status 200, 124 | :headers {"Content-Type" "text/plain"} 125 | :body response})))) 126 | 127 | (defn handler [_] 128 | (let [cf (CompletableFuture.)] 129 | (.complete cf "Hello, Async?") 130 | (.thenApply cf (reify Function 131 | (apply [_ response] 132 | {:status 200, 133 | :headers {"Content-Type" "text/plain"} 134 | :body response}))))) 135 | 136 | (defn handler [_] 137 | (-> (p/promise "Hello, Async!") 138 | (p/then (fn [message] 139 | {:status 200, 140 | :headers {"Content-Type" "text/plain"} 141 | :body message})))) 142 | 143 | (defn handler [_] 144 | (-> (a/promise "Hello, Async!") 145 | (a/then (fn [message] 146 | {:status 200, 147 | :headers {"Content-Type" "text/plain"} 148 | :body message})))) 149 | 150 | (defn handler2 [_] 151 | (-> (pa/query-one async-mapper async-pool ["SELECT id, randomnumber from WORLD where id=$1" (random)]) 152 | (.thenApply (reify Function 153 | (apply [_ world] 154 | {:status 200 155 | :headers {"Content-Type" "application/json"} 156 | :body (j/write-value-as-bytes world)}))))) 157 | 158 | (defmacro thread-local [& body] 159 | `(let [tl# (ThreadLocal/withInitial 160 | (reify Supplier 161 | (get [_] ~@body)))] 162 | (reify IDeref 163 | (deref [_] (.get tl#))))) 164 | 165 | (def async-pool-provider 166 | (thread-local 167 | (println "create in:" (Thread/currentThread)) 168 | (pa/pool 169 | {:uri "postgresql://localhost:5432/hello_world" 170 | :user "benchmarkdbuser" 171 | :password "benchmarkdbpass" 172 | :size 1}))) 173 | 174 | (defn handler [_] 175 | (-> (pa/query-one async-mapper @async-pool-provider #_async-pool ["SELECT id, randomnumber from WORLD where id=$1" (random)]) 176 | (pa/then (fn [world] 177 | {:status 200 178 | :headers {"Content-Type" "application/json"} 179 | :body (j/write-value-as-bytes world)})) 180 | (pa/catch (fn [e] 181 | {:status 500 182 | :headers {"Content-Type" "text/plain"} 183 | :body (ex-message e)})))) 184 | 185 | (defn handler2 [_] 186 | {:status 200 187 | :headers {"Content-Type" "text/plain"} 188 | :body "hello World!"}) 189 | 190 | (def handler (exchange/dispatch sync-db-handler)) 191 | (def handler (exchange/constantly handler2)) 192 | 193 | (comment 194 | (def server (server/create #'handler)) 195 | (def server (server/create http-handler)) 196 | (server/start server) 197 | (server/stop server) 198 | 199 | (jetty/run-jetty #'handler {:port 8088, :join? false})) 200 | -------------------------------------------------------------------------------- /src/inline/riddley/walk.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from riddley, v0.1.12 (https://github.com/ztellman/riddley), MIT licnensed, Copyright Zachary Tellman 2 | 3 | (ns ^:no-doc inline.riddley.walk 4 | (:refer-clojure :exclude [macroexpand]) 5 | (:require 6 | [inline.riddley.compiler :as cmp])) 7 | 8 | (defn macroexpand 9 | "Expands both macros and inline functions. Optionally takes a `special-form?` predicate which 10 | identifies first elements of expressions that shouldn't be macroexpanded, and honors local 11 | bindings." 12 | ([x] 13 | (macroexpand x nil)) 14 | ([x special-form?] 15 | (cmp/with-base-env 16 | (if (seq? x) 17 | (let [frst (first x)] 18 | 19 | (if (or 20 | (and special-form? (special-form? frst)) 21 | (contains? (cmp/locals) frst)) 22 | 23 | ;; might look like a macro, but for our purposes it isn't 24 | x 25 | 26 | (let [x' (macroexpand-1 x)] 27 | (if-not (identical? x x') 28 | (macroexpand x' special-form?) 29 | 30 | ;; if we can't macroexpand any further, check if it's an inlined function 31 | (if-let [inline-fn (and (seq? x') 32 | (symbol? (first x')) 33 | (-> x' meta ::transformed not) 34 | (or 35 | (-> x' first resolve meta :inline-arities not) 36 | ((-> x' first resolve meta :inline-arities) 37 | (count (rest x')))) 38 | (-> x' first resolve meta :inline))] 39 | (let [x'' (apply inline-fn (rest x'))] 40 | (macroexpand 41 | ;; unfortunately, static function calls can look a lot like what we just 42 | ;; expanded, so prevent infinite expansion 43 | (if (= '. (first x'')) 44 | (with-meta 45 | (concat (butlast x'') 46 | [(if (instance? clojure.lang.IObj (last x'')) 47 | (with-meta (last x'') 48 | (merge 49 | (meta (last x'')) 50 | {::transformed true})) 51 | (last x''))]) 52 | (meta x'')) 53 | x'') 54 | special-form?)) 55 | x'))))) 56 | x)))) 57 | 58 | ;;; 59 | 60 | (defn- do-handler [f [_ & body]] 61 | (list* 'do 62 | (doall 63 | (map f body)))) 64 | 65 | (defn- fn-handler [f x] 66 | (let [prelude (take-while (complement sequential?) x) 67 | remainder (drop (count prelude) x) 68 | remainder (if (vector? (first remainder)) 69 | (list remainder) remainder) 70 | body-handler (fn [x] 71 | (cmp/with-lexical-scoping 72 | (doseq [arg (first x)] 73 | (cmp/register-arg arg)) 74 | (doall 75 | (list* (first x) 76 | (map f (rest x))))))] 77 | 78 | (cmp/with-lexical-scoping 79 | 80 | ;; register a local for the function, if it's named 81 | (when-let [nm (second prelude)] 82 | (cmp/register-local nm 83 | (list* 'fn* nm 84 | (map #(take 1 %) remainder)))) 85 | 86 | (concat 87 | prelude 88 | (if (seq? (first remainder)) 89 | (doall (map body-handler remainder)) 90 | [(body-handler remainder)]))))) 91 | 92 | (defn- def-handler [f x] 93 | (let [[_ n & r] x] 94 | (cmp/with-lexical-scoping 95 | (cmp/register-local n '()) 96 | (list* 'def (f n) (doall (map f r)))))) 97 | 98 | (defn- let-bindings [f x] 99 | (->> x 100 | (partition-all 2) 101 | (mapcat 102 | (fn [[k v]] 103 | (let [[k v] [k (f v)]] 104 | (cmp/register-local k v) 105 | [k v]))) 106 | vec)) 107 | 108 | (defn- reify-handler [f x] 109 | (let [[_ classes & fns] x] 110 | (list* 'reify* classes 111 | (doall 112 | (map 113 | (fn [[nm args & body]] 114 | (cmp/with-lexical-scoping 115 | (doseq [arg args] 116 | (cmp/register-arg arg)) 117 | (list* nm args (doall (map f body))))) 118 | fns))))) 119 | 120 | (defn- deftype-handler [f x] 121 | (let [[_ type resolved-type args _ interfaces & fns] x] 122 | (cmp/with-lexical-scoping 123 | (doseq [arg args] 124 | (cmp/register-arg arg)) 125 | (list* 'deftype* type resolved-type args :implements interfaces 126 | (doall 127 | (map 128 | (fn [[nm args & body]] 129 | (cmp/with-lexical-scoping 130 | (doseq [arg args] 131 | (cmp/register-arg arg)) 132 | (list* nm args (doall (map f body))))) 133 | fns)))))) 134 | 135 | (defn- let-handler [f x] 136 | (cmp/with-lexical-scoping 137 | (doall 138 | (list* 139 | (first x) 140 | (let-bindings f (second x)) 141 | (map f (drop 2 x)))))) 142 | 143 | (defn- case-handler [f x] 144 | (let [prefix (butlast (take-while (complement map?) x)) 145 | default (last (take-while (complement map?) x)) 146 | body (first (drop-while (complement map?) x)) 147 | suffix (rest (drop-while (complement map?) x))] 148 | (concat 149 | prefix 150 | [(f default)] 151 | [(let [m (->> body 152 | (map 153 | (fn [[k [idx form]]] 154 | [k [idx (f form)]])) 155 | (into {}))] 156 | (if (every? number? (keys m)) 157 | (into (sorted-map) m) 158 | m))] 159 | suffix))) 160 | 161 | (defn- catch-handler [f x] 162 | (let [[_ type var & body] x] 163 | (cmp/with-lexical-scoping 164 | (when var 165 | (cmp/register-arg (with-meta var (merge (meta var) {:tag type})))) 166 | (list* 'catch type var 167 | (doall (map f body)))))) 168 | 169 | (defn- dot-handler [f x] 170 | (let [[_ hostexpr mem-or-meth & remainder] x] 171 | (list* '. 172 | (f hostexpr) 173 | (if (seq? mem-or-meth) 174 | (list* (first mem-or-meth) 175 | (doall (map f (rest mem-or-meth)))) 176 | (f mem-or-meth)) 177 | (doall (map f remainder))))) 178 | 179 | (defn walk-exprs 180 | "A walk function which only traverses valid Clojure expressions. The `predicate` describes 181 | whether the sub-form should be transformed. If it returns true, `handler` is invoked, and 182 | returns a transformed form. 183 | 184 | Unlike `clojure.walk`, if the handler is called, the rest of the sub-form is not walked. 185 | The handler function is responsible for recursively calling `walk-exprs` on the form it is 186 | given. 187 | 188 | Macroexpansion can be halted by defining a set of `special-form?` which will be left alone. 189 | Including `fn`, `let`, or other binding forms can break local variable analysis, so use 190 | with caution." 191 | ([predicate handler x] 192 | (walk-exprs predicate handler nil x)) 193 | ([predicate handler special-form? x] 194 | (cmp/with-base-env 195 | (let [x (try 196 | (macroexpand x special-form?) 197 | (catch ClassNotFoundException _ 198 | x)) 199 | walk-exprs' (partial walk-exprs predicate handler special-form?) 200 | x' (cond 201 | 202 | (and (seq? x) (= 'var (first x)) (predicate x)) 203 | (handler (eval x)) 204 | 205 | (and (seq? x) (= 'quote (first x)) (not (predicate x))) 206 | x 207 | 208 | (predicate x) 209 | (handler x) 210 | 211 | (seq? x) 212 | ((condp = (first x) 213 | 'do do-handler 214 | 'def def-handler 215 | 'fn* fn-handler 216 | 'let* let-handler 217 | 'loop* let-handler 218 | 'letfn* let-handler 219 | 'case* case-handler 220 | 'catch catch-handler 221 | 'reify* reify-handler 222 | 'deftype* deftype-handler 223 | '. dot-handler 224 | #(doall (map %1 %2))) 225 | walk-exprs' x) 226 | 227 | (instance? java.util.Map$Entry x) 228 | (clojure.lang.MapEntry. 229 | (walk-exprs' (key x)) 230 | (walk-exprs' (val x))) 231 | 232 | (or 233 | (set? x) 234 | (vector? x)) 235 | (into (empty x) (map walk-exprs' x)) 236 | 237 | (instance? clojure.lang.IRecord x) 238 | x 239 | 240 | (map? x) 241 | (into (empty x) (map walk-exprs' x)) 242 | 243 | ;; special case to handle clojure.test 244 | (and (symbol? x) (-> x meta :test)) 245 | (vary-meta x update-in [:test] walk-exprs') 246 | 247 | :else 248 | x)] 249 | (if (instance? clojure.lang.IObj x') 250 | (with-meta x' (merge (meta x) (meta x'))) 251 | x'))))) 252 | 253 | ;;; 254 | 255 | (defn macroexpand-all 256 | "Recursively macroexpands all forms, preserving the &env special variables." 257 | [x] 258 | (walk-exprs (constantly false) nil x)) 259 | -------------------------------------------------------------------------------- /src/inline/potemkin/collections.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from potemkin, v0.4.3 (https://github.com/ztellman/potemkin), MIT licnensed, Copyright Zachary Tellman 2 | 3 | (ns ^:no-doc inline.potemkin.collections 4 | (:use 5 | [inline.potemkin types macros utils])) 6 | 7 | (defprotocol PotemkinMap 8 | (empty* [m]) 9 | (get* [m k default]) 10 | (assoc* [m k v]) 11 | (dissoc* [m k]) 12 | (keys* [m]) 13 | (with-meta* [o mta]) 14 | (meta* [o])) 15 | 16 | (defprotocol PotemkinMeta 17 | (meta-atom [_]) 18 | (with-meta-atom [_ x])) 19 | 20 | (defn throw-arity [actual] 21 | `(throw 22 | (RuntimeException. 23 | ~(str "Wrong number of args (" actual ")")))) 24 | 25 | (defmacro compile-if [test then else] 26 | (if (eval test) 27 | then 28 | else)) 29 | 30 | (eval 31 | (unify-gensyms 32 | `(def-abstract-type PotemkinFn 33 | java.util.concurrent.Callable 34 | (call [this##] 35 | (.invoke ~(with-meta `this## {:tag "clojure.lang.IFn"}))) 36 | 37 | java.lang.Runnable 38 | (run [this##] 39 | (.invoke ~(with-meta `this## {:tag "clojure.lang.IFn"}))) 40 | 41 | clojure.lang.IFn 42 | ~@(map 43 | (fn [n] 44 | `(~'invoke [this# ~@(repeat n '_)] 45 | ~(throw-arity n))) 46 | (range 0 21)) 47 | 48 | (applyTo [this## args##] 49 | (let [cnt# (count args##)] 50 | (case cnt# 51 | ~@(mapcat 52 | (fn [n] 53 | `[~n (.invoke 54 | ~(with-meta `this## {:tag "clojure.lang.IFn"}) 55 | ~@(map (fn [arg] `(nth args## ~arg)) (range n)))]) 56 | (range 0 21)))))))) 57 | 58 | (def-abstract-type AbstractMap 59 | 60 | inline.potemkin.collections.PotemkinMap 61 | 62 | clojure.lang.MapEquivalence 63 | 64 | clojure.lang.IPersistentCollection 65 | 66 | (equiv [this x] 67 | (and (map? x) (= x (into {} this)))) 68 | 69 | (cons [this o] 70 | (if (map? o) 71 | (reduce #(apply assoc %1 %2) this o) 72 | (if-let [[k v] (seq o)] 73 | (assoc this k v) 74 | this))) 75 | 76 | clojure.lang.IObj 77 | (withMeta [this mta] 78 | (inline.potemkin.collections/with-meta* this mta)) 79 | (meta [this] 80 | (inline.potemkin.collections/meta* this)) 81 | (meta* [this] 82 | nil) 83 | 84 | clojure.lang.Counted 85 | 86 | (count [this] 87 | (count (inline.potemkin.collections/keys* this))) 88 | 89 | clojure.lang.Seqable 90 | (seq [this] 91 | (seq 92 | (map 93 | #(inline.potemkin.PersistentMapProxy$MapEntry. this %) 94 | (inline.potemkin.collections/keys* this)))) 95 | 96 | ^{:min-version "1.4.0"} 97 | clojure.core.protocols.CollReduce 98 | 99 | ^{:min-version "1.4.0"} 100 | (coll-reduce 101 | [this f] 102 | (reduce f (seq this))) 103 | 104 | ^{:min-version "1.4.0"} 105 | (coll-reduce 106 | [this f val#] 107 | (reduce f val# (seq this))) 108 | 109 | clojure.lang.IHashEq 110 | (hasheq [this] 111 | (inline.potemkin.collections/compile-if (resolve 'clojure.core/hash-unordered-coll) 112 | (hash-unordered-coll (or (seq this) ())) 113 | (reduce 114 | (fn [acc [k v]] 115 | (unchecked-add acc (bit-xor (hash k) (hash v)))) 116 | 0 117 | (seq this)))) 118 | 119 | Object 120 | (hashCode [this] 121 | (reduce 122 | (fn [acc [k v]] 123 | (unchecked-add acc (bit-xor (clojure.lang.Util/hash k) 124 | (clojure.lang.Util/hash v)))) 125 | 0 126 | (seq this))) 127 | 128 | (equals [this x] 129 | (or (identical? this x) 130 | (and 131 | (map? x) 132 | (= x (into {} this))))) 133 | 134 | (toString [this] 135 | (str (into {} this))) 136 | 137 | clojure.lang.ILookup 138 | (valAt [this k] 139 | (.valAt this k nil)) 140 | (valAt [this k default] 141 | (inline.potemkin.collections/get* this k default)) 142 | 143 | clojure.lang.Associative 144 | (containsKey [this k] 145 | (contains? (.keySet this) k)) 146 | 147 | (entryAt [this k] 148 | (when (contains? (.keySet this) k) 149 | (inline.potemkin.PersistentMapProxy$MapEntry. this k))) 150 | 151 | (assoc [this k v] 152 | (inline.potemkin.collections/assoc* this k v)) 153 | 154 | (empty* [this] 155 | {}) 156 | 157 | (empty [this] 158 | (inline.potemkin.collections/empty* this)) 159 | 160 | java.util.Map 161 | (get [this k] 162 | (.valAt this k)) 163 | (isEmpty [this] 164 | (empty? this)) 165 | (size [this] 166 | (count this)) 167 | (keySet [this] 168 | (set (inline.potemkin.collections/keys* this))) 169 | (put [_ _ _] 170 | (throw (UnsupportedOperationException.))) 171 | (putAll [_ _] 172 | (throw (UnsupportedOperationException.))) 173 | (clear [_] 174 | (throw (UnsupportedOperationException.))) 175 | (remove [_ _] 176 | (throw (UnsupportedOperationException.))) 177 | (values [this] 178 | (->> this seq (map second))) 179 | (entrySet [this] 180 | (->> this seq set)) 181 | 182 | java.util.Iterator 183 | (iterator [this] 184 | (clojure.lang.SeqIterator. this)) 185 | 186 | clojure.lang.IPersistentMap 187 | (assocEx [this k v] 188 | (if (contains? this k) 189 | (throw (Exception. "Key or value already present")) 190 | (assoc this k v))) 191 | (without [this k] 192 | (inline.potemkin.collections/dissoc* this k)) 193 | 194 | inline.potemkin.collections/PotemkinFn 195 | 196 | (invoke [this k] 197 | (inline.potemkin.collections/get* this k nil)) 198 | (invoke [this k default] 199 | (inline.potemkin.collections/get* this k default))) 200 | 201 | (defmacro def-map-type 202 | "Like deftype, but must contain definitions for the following functions: 203 | 204 | (get [this key default-value]) 205 | (assoc [this key value]) 206 | (dissoc [this key]) 207 | (keys [this]) 208 | (meta [this]) 209 | (with-meta [this meta]) 210 | 211 | All other necessary functions will be defined so that this behaves like a normal 212 | Clojure map. These can be overriden, if desired." 213 | [name params & body] 214 | (let [fns '{get get* 215 | assoc assoc* 216 | dissoc dissoc* 217 | keys keys* 218 | empty empty* 219 | with-meta with-meta* 220 | meta meta*} 221 | classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))] 222 | (unify-gensyms 223 | `(do 224 | (deftype+ ~name ~params ~'inline.potemkin.collections/AbstractMap 225 | ~@(map 226 | #(if (sequential? %) 227 | (list* (get fns (first %) (first %)) (rest %)) 228 | %) 229 | body)) 230 | ~classname)))) 231 | 232 | (defmacro reify-map-type 233 | "Like reify, but must contain definitions for the following functions: 234 | 235 | (get [this key default-value]) 236 | (assoc [this key value]) 237 | (dissoc [this key]) 238 | (keys [this]) 239 | 240 | All other necessary functions will be defined so that this behaves like a normal 241 | Clojure map. These can be overriden, if desired." 242 | [& body] 243 | (let [fns '{get get* 244 | assoc assoc* 245 | dissoc dissoc* 246 | keys keys* 247 | empty empty*} 248 | elide? '#{withMeta meta}] 249 | (->> 250 | `(reify+ ~'inline.potemkin.collections/AbstractMap 251 | ~@(map 252 | #(if (sequential? %) 253 | (list* (get fns (first %) (first %)) (rest %)) 254 | %) 255 | body)) 256 | macroexpand 257 | (remove 258 | #(if (sequential? %) 259 | (elide? (first %)) 260 | false))))) 261 | 262 | (defmacro def-derived-map 263 | "Allows a map type to be defined where key-value pairs may be derived from fields. 264 | 265 | For instance, if we want to create a map which contains both upper and lower-case 266 | versions of a string without immediately instantiating both, we can do this: 267 | 268 | (def-derived-map StringMap [^String s] 269 | :lower-case (.toLowerCase s) 270 | :upper-case (.toUpperCase s)) 271 | 272 | The resulting map will behave correctly if the defined keys are removed, shadowed, 273 | etc. 274 | 275 | The above class will automatically create a constructor named '->StringMap'." 276 | [name params & {:as m}] 277 | (let [interface (symbol (str "ILookup" name)) 278 | methods (->> (count m) range (map #(symbol (str "get__" %)))) 279 | key-set (set (keys m))] 280 | (unify-gensyms 281 | `(do 282 | 283 | (definterface ~interface 284 | ~@(map 285 | #(list % []) 286 | methods)) 287 | 288 | (def-map-type ~name ~(vec (conj params `key-set## `added## `meta##)) 289 | 290 | ~interface 291 | ~@(->> (map vector methods (vals m)) 292 | (map 293 | (fn [[name f]] 294 | (list name `[_#] f)))) 295 | 296 | (~'meta [_] meta##) 297 | 298 | (~'with-meta [_ x#] 299 | (new ~name ~@params key-set## added## x#)) 300 | 301 | (~'get [this## key# default-value#] 302 | (if-let [e# (find added## key#)] 303 | (val e#) 304 | (if (contains? key-set## key#) 305 | (case key# 306 | ~@(interleave 307 | (keys m) 308 | (map (fn [m] `(~(symbol (str "." m)) this##)) methods)) 309 | default-value#) 310 | default-value#))) 311 | 312 | (~'keys [this#] 313 | key-set##) 314 | 315 | (~'assoc [this# key# value#] 316 | (new ~name ~@params 317 | (conj key-set## key#) 318 | (assoc added## key# value#) 319 | meta##)) 320 | 321 | (~'dissoc [this# key#] 322 | (new ~name ~@params 323 | (disj key-set## key#) 324 | (dissoc added## key#) 325 | meta##))) 326 | 327 | (let [key-set# ~key-set] 328 | (defn ~(symbol (str "->" name)) [~@params] 329 | (new ~name ~@params key-set# nil nil))))))) 330 | -------------------------------------------------------------------------------- /src/inline/potemkin/types.clj: -------------------------------------------------------------------------------- 1 | ;; Copied and modified from potemkin, v0.4.3 (https://github.com/ztellman/potemkin), MIT licnensed, Copyright Zachary Tellman 2 | 3 | (ns ^:no-doc inline.potemkin.types 4 | (:use 5 | [clojure [set :only (union)]] 6 | [inline.potemkin.macros :only (equivalent? normalize-gensyms safe-resolve unify-gensyms)]) 7 | (:require 8 | [inline.riddley.walk :as r] 9 | [clojure.set :as set] 10 | [clojure.string :as str])) 11 | 12 | ;;; 13 | 14 | (definterface PotemkinType) 15 | 16 | ;;; 17 | 18 | (defn protocol? [x] 19 | (and 20 | (contains? x :on-interface) 21 | (class? (:on-interface x)))) 22 | 23 | (defn- extend-implementations [proto impls body] 24 | (let [proto-val @(resolve proto) 25 | impls (remove 26 | #(or 27 | (= (:on-interface proto-val) %) 28 | (contains? (:impls proto-val) %)) 29 | impls)] 30 | (eval 31 | `(extend-protocol ~proto 32 | ~@(apply concat 33 | (interleave (map list impls) (repeat body))))))) 34 | 35 | (defn- register-impl-callback [proto-var callback] 36 | (add-watch proto-var callback 37 | (fn [_ proto-var {old-impls :impls} {new-impls :impls}] 38 | (callback (set/difference (set (keys new-impls)) (set (keys old-impls))))))) 39 | 40 | (defmacro extend-protocol+ 41 | "A variant of `extend-protocol` that allows `proto` to be extended over other protocols, as well as classes and `nil`." 42 | [proto & body] 43 | (let [split-on-symbol (fn this [[sym & rest :as s]] 44 | (when-not (empty? s) 45 | (lazy-seq 46 | (cons 47 | (cons sym (take-while (complement symbol?) rest)) 48 | (this (drop-while (complement symbol?) rest)))))) 49 | decls (split-on-symbol body) 50 | protocol? (fn [[sym]] 51 | (let [x (resolve sym)] 52 | (and (var? x) (protocol? @x)))) 53 | protos (filter protocol? decls) 54 | classes (remove protocol? decls)] 55 | 56 | (doseq [[target-proto & body] protos] 57 | (let [target-proto-var (resolve target-proto)] 58 | 59 | ;; all future implementations should be extended 60 | (register-impl-callback target-proto-var 61 | (fn [new-impls] 62 | (extend-implementations proto new-impls body))) 63 | 64 | ;; all current implementations should be extended 65 | (let [{:keys [on-interface impls]} @target-proto-var] 66 | (extend-implementations proto (cons on-interface (keys impls)) body)))) 67 | 68 | `(extend-protocol ~proto 69 | ~@(apply concat classes)))) 70 | 71 | ;;; 72 | 73 | (defn clean-deftype [x] 74 | (let [version (let [{:keys [major minor incremental ]} *clojure-version*] 75 | (str major "." minor "." incremental))] 76 | (remove 77 | #(when-let [min-version (-> % meta :min-version)] 78 | (neg? (.compareTo version min-version))) 79 | x))) 80 | 81 | (declare merge-deftypes* deftype->deftype*) 82 | 83 | (defn abstract-type? [x] 84 | (and (symbol? x) (= :inline.potemkin/abstract-type (-> x safe-resolve meta :tag)))) 85 | 86 | (def ^:dynamic *expanded-types* #{}) 87 | 88 | (defn expand-deftype [x] 89 | (let [abstract-types (->> x 90 | (filter abstract-type?) 91 | (map resolve) 92 | (remove *expanded-types*) 93 | set) 94 | abstract-type-bodies (binding [*expanded-types* (union *expanded-types* abstract-types)] 95 | (->> abstract-types 96 | (map deref) 97 | (map clean-deftype) 98 | (map expand-deftype) 99 | (map deftype->deftype*) 100 | doall))] 101 | (apply merge-deftypes* 102 | (concat 103 | abstract-type-bodies 104 | [(deftype->deftype* 105 | (if (abstract-type? (second x)) 106 | x 107 | (remove abstract-type? x)))])))) 108 | 109 | ;;; 110 | 111 | (defn transform-deftype* 112 | [f x] 113 | (r/walk-exprs 114 | #(and (sequential? %) (= 'deftype* (first %))) 115 | f 116 | x)) 117 | 118 | (defn deftype->deftype* [x] 119 | (let [x (r/macroexpand x) 120 | find-deftype* (fn find-deftype* [x] 121 | (when (sequential? x) 122 | (let [f (first x)] 123 | (if (= 'deftype* f) 124 | x 125 | (first (filter find-deftype* x)))))) 126 | remove-nil-implements (fn [x] 127 | (concat 128 | (take 5 x) 129 | [(->> (nth x 5) (remove nil?) vec)] 130 | (drop 6 x)))] 131 | (->> x 132 | find-deftype* 133 | remove-nil-implements))) 134 | 135 | (defn deftype*->deftype [x] 136 | (let [[_ dname _ params _ implements & body] (deftype->deftype* x)] 137 | (list* 'deftype (symbol (name dname)) params (concat (remove #{'clojure.lang.IType} implements) body)))) 138 | 139 | (defn deftype*->fn-map [x] 140 | (let [fns (drop 6 x) 141 | fn->key (fn [f] [(first f) (map #(-> % meta :tag) (second f))])] 142 | (zipmap 143 | (map fn->key fns) 144 | fns))) 145 | 146 | (defn merge-deftypes* 147 | ([a] 148 | a) 149 | ([a b & rest] 150 | (let [fns (vals 151 | (merge 152 | (deftype*->fn-map a) 153 | (deftype*->fn-map b))) 154 | a-implements (nth a 5) 155 | merged (transform-deftype* 156 | #(concat 157 | (take 5 %) 158 | [(->> (nth % 5) (concat a-implements) distinct vec)] 159 | fns) 160 | b)] 161 | (if-not (empty? rest) 162 | (apply merge-deftypes* merged rest) 163 | merged)))) 164 | 165 | ;;; 166 | 167 | (defmacro def-abstract-type 168 | "An abstract type, which can be used in conjunction with deftype+." 169 | [name & body] 170 | `(def 171 | ~(with-meta name {:tag :inline.potemkin/abstract-type}) 172 | '(deftype ~name [] ~@body))) 173 | 174 | (defmacro defprotocol+ 175 | "A protocol that won't evaluate if an equivalent protocol with the same name already exists." 176 | [name & body] 177 | (let [prev-body (-> name resolve meta :inline.potemkin/body)] 178 | (when-not (equivalent? prev-body body) 179 | `(let [p# (defprotocol ~name ~@body)] 180 | (alter-meta! (resolve p#) assoc :inline.potemkin/body '~(r/macroexpand-all body)) 181 | p#)))) 182 | 183 | ;;; 184 | 185 | (def clojure-fn-subs 186 | [[#"\?" "_QMARK_"] 187 | [#"\-" "_"] 188 | [#"!" "_BANG_"] 189 | [#"\+" "_PLUS_"] 190 | [#">" "_GT_"] 191 | [#"<" "_LT_"] 192 | [#"=" "_EQ_"] 193 | [#"\*" "_STAR_"] 194 | [#"/" "_SLASH_"]]) 195 | 196 | (defn munge-fn-name [n] 197 | (with-meta 198 | (symbol 199 | (reduce 200 | (fn [s [regex replacement]] 201 | (str/replace s regex replacement)) 202 | (name n) 203 | clojure-fn-subs)) 204 | (meta n))) 205 | 206 | (defn resolve-tag [n] 207 | (if-let [tag (-> n meta :tag)] 208 | (with-meta n 209 | (assoc (meta n) 210 | :tag (or 211 | (#{'long 'double 'short 'int 'byte 'boolean 'void} tag) 212 | (resolve tag)))) 213 | n)) 214 | 215 | (defn untag [n] 216 | (with-meta n (dissoc (meta n) :tag))) 217 | 218 | (defmacro definterface+ 219 | "An interface that won't evaluate if an interface with that name already exists. 220 | 221 | Self parameters and multiple arities are defined like defprotocol, as well as wrapping 222 | functions for each, so it can be used to replace defprotocol seamlessly." 223 | [name & body] 224 | 225 | (let [fn-names (map first body) 226 | unrolled-body (mapcat 227 | (fn [[fn-name & arg-lists+doc-string]] 228 | (let [arg-lists (remove string? arg-lists+doc-string)] 229 | (map 230 | #(list 231 | (with-meta 232 | (munge-fn-name fn-name) 233 | {:tag (-> % resolve-tag meta :tag)}) 234 | (resolve-tag 235 | (vec (map resolve-tag (rest %))))) 236 | arg-lists))) 237 | body) 238 | class-name (str/replace (str *ns* "." name) #"\-" "_")] 239 | 240 | `(let [p# ~(if (try 241 | (Class/forName class-name) 242 | true 243 | (catch Exception _ 244 | false)) 245 | 246 | ;; already exists, just re-import it 247 | `(do 248 | (import ~(symbol class-name)) 249 | nil) 250 | 251 | ;; define the interface 252 | `(definterface 253 | ~name 254 | ~@unrolled-body))] 255 | 256 | ~@(map 257 | (fn [[fn-name & arg-lists+doc-string]] 258 | (let [arg-lists (remove string? arg-lists+doc-string) 259 | doc-string (filter string? arg-lists+doc-string) 260 | form-fn `(fn 261 | ~@(map 262 | (fn [args] 263 | (let [args (map untag args)] 264 | `( 265 | ;; args 266 | ~(vec args) 267 | 268 | (with-meta 269 | (list 270 | '~(symbol (str "." (munge-fn-name fn-name))) 271 | (with-meta (r/macroexpand ~(first args)) {:tag ~class-name}) 272 | ~@(rest args)) 273 | {:tag ~(-> args meta :tag)})))) 274 | arg-lists))] 275 | 276 | (unify-gensyms 277 | `(defn ~fn-name 278 | ~@doc-string 279 | {:inline ~form-fn} 280 | ~@(let [f (eval form-fn)] 281 | (map 282 | #(list (resolve-tag %) (apply f (map untag %))) 283 | arg-lists)))))) 284 | body) 285 | 286 | p#))) 287 | 288 | ;;; 289 | 290 | (defonce type-bodies (atom {})) 291 | 292 | (defmacro deftype+ 293 | "A deftype that won't evaluate if an equivalent datatype with the same name already exists, 294 | and allows abstract types to be used." 295 | [name params & body] 296 | (let [body (->> (list* 'deftype name params 'inline.potemkin.types.PotemkinType body) 297 | clean-deftype 298 | expand-deftype 299 | deftype*->deftype) 300 | 301 | classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) 302 | 303 | prev-body (when (class? (ns-resolve *ns* name)) 304 | (@type-bodies classname))] 305 | 306 | (when-not (and prev-body 307 | (equivalent? 308 | (transform-deftype* identity prev-body) 309 | (transform-deftype* identity body))) 310 | (swap! type-bodies assoc classname 311 | (r/macroexpand-all body)) 312 | 313 | body))) 314 | 315 | (defmacro reify+ 316 | "A reify that supports abstract types." 317 | [& body] 318 | (let [body (->> (list* 'deftype (gensym "reify") [] 'inline.potemkin.types.PotemkinType body) 319 | clean-deftype 320 | expand-deftype 321 | deftype*->deftype)] 322 | 323 | `(reify ~@(->> body (drop 3) (remove #{'clojure.lang.IObj clojure.lang.IObj}))))) 324 | 325 | ;;; 326 | 327 | (defmacro defrecord+ 328 | "A defrecord that won't evaluate if an equivalent datatype with the same name already exists." 329 | [name & body] 330 | (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) 331 | 332 | prev-body (when (class? (ns-resolve *ns* name)) 333 | (@type-bodies classname)) 334 | body' (list* 'deftype name body)] 335 | 336 | (when-not (and prev-body 337 | (equivalent? 338 | body' 339 | prev-body)) 340 | 341 | (swap! type-bodies assoc classname (r/macroexpand-all body')) 342 | 343 | `(defrecord ~name ~@body)))) 344 | --------------------------------------------------------------------------------