Allow freeze, thaw opts to override bindings
This commit is contained in:
Peter Taoussanis
parent
57eae96c7b
commit
b6c1c09419
1 changed files with 140 additions and 105 deletions
|
|
@ -994,65 +994,97 @@
|
||||||
(with-cache (-freeze-with-meta! x dos))
|
(with-cache (-freeze-with-meta! x dos))
|
||||||
(.toByteArray baos)))
|
(.toByteArray baos)))
|
||||||
|
|
||||||
|
(defn- call-with-bindings
|
||||||
|
"Allow opts to override config bindings. Undocumented."
|
||||||
|
[opts f]
|
||||||
|
(let [opt->bindings
|
||||||
|
(fn [bindings id var]
|
||||||
|
(if-let [o (find opts id)]
|
||||||
|
(assoc bindings var (val o))
|
||||||
|
(do bindings)))
|
||||||
|
|
||||||
|
bindings
|
||||||
|
(-> nil
|
||||||
|
(opt->bindings :freeze-fallback #'*freeze-fallback*)
|
||||||
|
(opt->bindings :auto-freeze-compressor #'*auto-freeze-compressor*)
|
||||||
|
(opt->bindings :custom-readers #'*custom-readers*))]
|
||||||
|
|
||||||
|
(if-not bindings
|
||||||
|
(f) ; Common case
|
||||||
|
(try
|
||||||
|
(push-thread-bindings bindings)
|
||||||
|
(f)
|
||||||
|
(finally
|
||||||
|
(pop-thread-bindings))))))
|
||||||
|
|
||||||
|
(comment
|
||||||
|
(enc/qb 1e4
|
||||||
|
(call-with-bindings {} (fn [] *freeze-fallback*))
|
||||||
|
(call-with-bindings {:freeze-fallback "foo"} (fn [] *freeze-fallback*))))
|
||||||
|
|
||||||
(defn freeze
|
(defn freeze
|
||||||
"Serializes arg (any Clojure data type) to a byte array. To freeze custom
|
"Serializes arg (any Clojure data type) to a byte array. To freeze custom
|
||||||
types, extend the Clojure reader or see `extend-freeze`."
|
types, extend the Clojure reader or see `extend-freeze`."
|
||||||
([x] (freeze x nil))
|
([x] (freeze x nil))
|
||||||
([x {:keys [compressor encryptor password]
|
([x {:as opts
|
||||||
|
:keys [compressor encryptor password]
|
||||||
:or {compressor :auto
|
:or {compressor :auto
|
||||||
encryptor aes128-gcm-encryptor}
|
encryptor aes128-gcm-encryptor}}]
|
||||||
:as opts}]
|
|
||||||
(let [;; Intentionally undocumented:
|
|
||||||
no-header? (or (get opts :no-header?)
|
|
||||||
(get opts :skip-header?))
|
|
||||||
encryptor (when password encryptor)
|
|
||||||
baos (ByteArrayOutputStream. 64)
|
|
||||||
dos (DataOutputStream. baos)]
|
|
||||||
|
|
||||||
(if (and (nil? compressor) (nil? encryptor))
|
(call-with-bindings opts
|
||||||
(do ; Optimized case
|
(fn []
|
||||||
(when-not no-header? ; Avoid `wrap-header`'s array copy:
|
|
||||||
(let [head-ba (get-head-ba {:compressor-id nil :encryptor-id nil})]
|
|
||||||
(.write dos head-ba 0 4)))
|
|
||||||
(with-cache (-freeze-with-meta! x dos))
|
|
||||||
(.toByteArray baos))
|
|
||||||
|
|
||||||
(do
|
(let [;; Intentionally undocumented:
|
||||||
(with-cache (-freeze-with-meta! x dos))
|
no-header? (or (get opts :no-header?)
|
||||||
(let [ba (.toByteArray baos)
|
(get opts :skip-header?))
|
||||||
|
encryptor (when password encryptor)
|
||||||
|
baos (ByteArrayOutputStream. 64)
|
||||||
|
dos (DataOutputStream. baos)]
|
||||||
|
|
||||||
compressor
|
(if (and (nil? compressor) (nil? encryptor))
|
||||||
(if (identical? compressor :auto)
|
(do ; Optimized case
|
||||||
(if no-header?
|
(when-not no-header? ; Avoid `wrap-header`'s array copy:
|
||||||
lz4-compressor
|
(let [head-ba (get-head-ba {:compressor-id nil :encryptor-id nil})]
|
||||||
(if-let [fc *auto-freeze-compressor*]
|
(.write dos head-ba 0 4)))
|
||||||
(fc ba)
|
(with-cache (-freeze-with-meta! x dos))
|
||||||
;; Intelligently enable compression only if benefit
|
(.toByteArray baos))
|
||||||
;; is likely to outweigh cost:
|
|
||||||
(when (> (alength ba) 8192) lz4-compressor)))
|
|
||||||
|
|
||||||
(if (fn? compressor)
|
(do
|
||||||
(compressor ba) ; Assume compressor selector fn
|
(with-cache (-freeze-with-meta! x dos))
|
||||||
compressor ; Assume compressor
|
(let [ba (.toByteArray baos)
|
||||||
))
|
|
||||||
|
|
||||||
ba (if compressor (compress compressor ba) ba)
|
compressor
|
||||||
ba (if encryptor (encrypt encryptor password ba) ba)]
|
(if (identical? compressor :auto)
|
||||||
|
(if no-header?
|
||||||
|
lz4-compressor
|
||||||
|
(if-let [fc *auto-freeze-compressor*]
|
||||||
|
(fc ba)
|
||||||
|
;; Intelligently enable compression only if benefit
|
||||||
|
;; is likely to outweigh cost:
|
||||||
|
(when (> (alength ba) 8192) lz4-compressor)))
|
||||||
|
|
||||||
(if no-header?
|
(if (fn? compressor)
|
||||||
ba
|
(compressor ba) ; Assume compressor selector fn
|
||||||
(wrap-header ba
|
compressor ; Assume compressor
|
||||||
{:compressor-id
|
))
|
||||||
(when-let [c compressor]
|
|
||||||
(or (compression/standard-header-ids
|
|
||||||
(compression/header-id c))
|
|
||||||
:else))
|
|
||||||
|
|
||||||
:encryptor-id
|
ba (if compressor (compress compressor ba) ba)
|
||||||
(when-let [e encryptor]
|
ba (if encryptor (encrypt encryptor password ba) ba)]
|
||||||
(or (encryption/standard-header-ids
|
|
||||||
(encryption/header-id e))
|
(if no-header?
|
||||||
:else))}))))))))
|
ba
|
||||||
|
(wrap-header ba
|
||||||
|
{:compressor-id
|
||||||
|
(when-let [c compressor]
|
||||||
|
(or (compression/standard-header-ids
|
||||||
|
(compression/header-id c))
|
||||||
|
:else))
|
||||||
|
|
||||||
|
:encryptor-id
|
||||||
|
(when-let [e encryptor]
|
||||||
|
(or (encryption/standard-header-ids
|
||||||
|
(encryption/header-id e))
|
||||||
|
:else))}))))))))))
|
||||||
|
|
||||||
;;;; Thawing
|
;;;; Thawing
|
||||||
|
|
||||||
|
|
@ -1388,80 +1420,83 @@
|
||||||
|
|
||||||
([ba] (thaw ba nil))
|
([ba] (thaw ba nil))
|
||||||
([^bytes ba
|
([^bytes ba
|
||||||
{:keys [v1-compatibility? compressor encryptor password]
|
{:as opts
|
||||||
|
:keys [v1-compatibility? compressor encryptor password]
|
||||||
:or {compressor :auto
|
:or {compressor :auto
|
||||||
encryptor :auto}
|
encryptor :auto}}]
|
||||||
:as opts}]
|
|
||||||
|
|
||||||
(assert (not (get opts :headerless-meta))
|
(assert (not (get opts :headerless-meta))
|
||||||
":headerless-meta `thaw` opt removed in Nippy v2.7+")
|
":headerless-meta `thaw` opt removed in Nippy v2.7+")
|
||||||
|
|
||||||
(let [v2+? (not v1-compatibility?)
|
(call-with-bindings opts
|
||||||
no-header? (get opts :no-header?) ; Intentionally undocumented
|
(fn []
|
||||||
ex (fn ex
|
|
||||||
([ msg] (ex nil msg))
|
|
||||||
([e msg] (throw (ex-info (str "Thaw failed: " msg)
|
|
||||||
{:opts (assoc opts
|
|
||||||
:compressor compressor
|
|
||||||
:encryptor encryptor)}
|
|
||||||
e))))
|
|
||||||
|
|
||||||
thaw-data
|
(let [v2+? (not v1-compatibility?)
|
||||||
(fn [data-ba compressor-id encryptor-id ex-fn]
|
no-header? (get opts :no-header?) ; Intentionally undocumented
|
||||||
(let [compressor (if (identical? compressor :auto)
|
ex (fn ex
|
||||||
(get-auto-compressor compressor-id)
|
([ msg] (ex nil msg))
|
||||||
compressor)
|
([e msg] (throw (ex-info (str "Thaw failed: " msg)
|
||||||
encryptor (if (identical? encryptor :auto)
|
{:opts (assoc opts
|
||||||
(get-auto-encryptor encryptor-id)
|
:compressor compressor
|
||||||
encryptor)]
|
:encryptor encryptor)}
|
||||||
|
e))))
|
||||||
|
|
||||||
(when (and encryptor (not password))
|
thaw-data
|
||||||
(ex "Password required for decryption."))
|
(fn [data-ba compressor-id encryptor-id ex-fn]
|
||||||
|
(let [compressor (if (identical? compressor :auto)
|
||||||
|
(get-auto-compressor compressor-id)
|
||||||
|
compressor)
|
||||||
|
encryptor (if (identical? encryptor :auto)
|
||||||
|
(get-auto-encryptor encryptor-id)
|
||||||
|
encryptor)]
|
||||||
|
|
||||||
(try
|
(when (and encryptor (not password))
|
||||||
(let [ba data-ba
|
(ex "Password required for decryption."))
|
||||||
ba (if encryptor (decrypt encryptor password ba) ba)
|
|
||||||
ba (if compressor (decompress compressor ba) ba)
|
|
||||||
dis (DataInputStream. (ByteArrayInputStream. ba))]
|
|
||||||
|
|
||||||
(with-cache (thaw-from-in! dis)))
|
(try
|
||||||
|
(let [ba data-ba
|
||||||
|
ba (if encryptor (decrypt encryptor password ba) ba)
|
||||||
|
ba (if compressor (decompress compressor ba) ba)
|
||||||
|
dis (DataInputStream. (ByteArrayInputStream. ba))]
|
||||||
|
|
||||||
(catch Exception e (ex-fn e)))))
|
(with-cache (thaw-from-in! dis)))
|
||||||
|
|
||||||
;; Hackish + can actually segfault JVM due to Snappy bug,
|
(catch Exception e (ex-fn e)))))
|
||||||
;; Ref. http://goo.gl/mh7Rpy - no better alternatives, unfortunately
|
|
||||||
thaw-v1-data
|
|
||||||
(fn [data-ba ex-fn]
|
|
||||||
(thaw-data data-ba :snappy nil
|
|
||||||
(fn [_] (thaw-data data-ba nil nil (fn [_] (ex-fn nil))))))]
|
|
||||||
|
|
||||||
(if no-header?
|
;; Hackish + can actually segfault JVM due to Snappy bug,
|
||||||
(if v2+?
|
;; Ref. http://goo.gl/mh7Rpy - no better alternatives, unfortunately
|
||||||
(thaw-data ba :no-header :no-header (fn [e] (ex e err-msg-unknown-thaw-failure)))
|
thaw-v1-data
|
||||||
(thaw-data ba :no-header :no-header
|
(fn [data-ba ex-fn]
|
||||||
(fn [e] (thaw-v1-data ba (fn [_] (ex e err-msg-unknown-thaw-failure))))))
|
(thaw-data data-ba :snappy nil
|
||||||
|
(fn [_] (thaw-data data-ba nil nil (fn [_] (ex-fn nil))))))]
|
||||||
|
|
||||||
;; At this point we assume that we have a header iff we have v2+ data
|
(if no-header?
|
||||||
(if-let [[data-ba {:keys [compressor-id encryptor-id unrecognized-meta?]
|
(if v2+?
|
||||||
:as head-meta}] (try-parse-header ba)]
|
(thaw-data ba :no-header :no-header (fn [e] (ex e err-msg-unknown-thaw-failure)))
|
||||||
|
(thaw-data ba :no-header :no-header
|
||||||
|
(fn [e] (thaw-v1-data ba (fn [_] (ex e err-msg-unknown-thaw-failure))))))
|
||||||
|
|
||||||
;; A well-formed header _appears_ to be present (it's possible though
|
;; At this point we assume that we have a header iff we have v2+ data
|
||||||
;; unlikely that this is a fluke and data is actually headerless):
|
(if-let [[data-ba {:keys [compressor-id encryptor-id unrecognized-meta?]
|
||||||
(if v2+?
|
:as head-meta}] (try-parse-header ba)]
|
||||||
(if unrecognized-meta?
|
|
||||||
(ex err-msg-unrecognized-header)
|
|
||||||
(thaw-data data-ba compressor-id encryptor-id
|
|
||||||
(fn [e] (ex e err-msg-unknown-thaw-failure))))
|
|
||||||
|
|
||||||
(if unrecognized-meta?
|
;; A well-formed header _appears_ to be present (it's possible though
|
||||||
(thaw-v1-data ba (fn [_] (ex err-msg-unrecognized-header)))
|
;; unlikely that this is a fluke and data is actually headerless):
|
||||||
(thaw-data data-ba compressor-id encryptor-id
|
(if v2+?
|
||||||
(fn [e] (thaw-v1-data ba (fn [_] (ex e err-msg-unknown-thaw-failure)))))))
|
(if unrecognized-meta?
|
||||||
|
(ex err-msg-unrecognized-header)
|
||||||
|
(thaw-data data-ba compressor-id encryptor-id
|
||||||
|
(fn [e] (ex e err-msg-unknown-thaw-failure))))
|
||||||
|
|
||||||
;; Well-formed header definitely not present
|
(if unrecognized-meta?
|
||||||
(if v2+?
|
(thaw-v1-data ba (fn [_] (ex err-msg-unrecognized-header)))
|
||||||
(ex err-msg-unknown-thaw-failure)
|
(thaw-data data-ba compressor-id encryptor-id
|
||||||
(thaw-v1-data ba (fn [_] (ex err-msg-unknown-thaw-failure)))))))))
|
(fn [e] (thaw-v1-data ba (fn [_] (ex e err-msg-unknown-thaw-failure)))))))
|
||||||
|
|
||||||
|
;; Well-formed header definitely not present
|
||||||
|
(if v2+?
|
||||||
|
(ex err-msg-unknown-thaw-failure)
|
||||||
|
(thaw-v1-data ba (fn [_] (ex err-msg-unknown-thaw-failure)))))))))))
|
||||||
|
|
||||||
(comment
|
(comment
|
||||||
(thaw (freeze "hello"))
|
(thaw (freeze "hello"))
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue