writers.clj
Branches > main > 7bcccfb > files / src / net / bowmap / server / protocol / writers.clj
(ns net.bowmap.server.protocol.writers
"Functions for writing values into write buffers.
Functions look like type>, where 'type' is a Minecraft protocol type.
See https://minecraft.wiki/w/Java_Edition_protocol/Packets#Data_types"
(:require
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[net.bowmap.server.protocol.buffer :as buffer]
[net.bowmap.server.protocol.identifier :as identifier]
[net.bowmap.server.protocol.schema :as p]
[net.bowmap.server.protocol.nbt :as nbt])
(:import
[java.nio.charset StandardCharsets]
[java.util UUID]))
(s/def ::writer (s/fspec
:args (s/cat :buf ::buffer/write-buffer
:value any?)
:fn #(= (-> % :args :buf)
(:ret %))))
(defn- write-key
"Writes a map key via the supplied writer, throwing a useful error message
when writing fails."
[writer buf m k]
(try
(writer buf (get m k))
(catch Exception e
(throw (ex-info "Error while writing map key."
{:key k
:val (get m k)
:writer writer
:in-map m}
e)))))
(defn map>
"Takes pairs of map keys and writers, and returns a writer that takes a map
and writes each key's mapped values (or nil) via its corresponding writer."
[& keys-and-writers]
{:pre [(even? (count keys-and-writers))]}
(let [pairs (partition 2 keys-and-writers)]
(fn map-writer [buf m]
(reduce (fn [acc [k writer]]
(write-key writer acc m k))
buf pairs))))
(def byte> buffer/write-byte!)
(defn- integer> [byte-count]
(let [range (range (* 8 (dec byte-count)) -1 -8)]
(fn [buf n]
(reduce (fn [acc bits]
(byte> acc (bit-shift-right n bits)))
buf range))))
(defn- apply>
"Returns a writer that writes (f x) via 'writer'."
[f writer]
(fn [buf x]
(try
(writer buf (f x))
(catch Exception e
(throw (ex-info "Failed to call writer with applied function" {:f f :writer writer} e))))))
(defn then>
"Returns a writer that writes (f x) to the buffer, then (g x)."
[f g]
(fn [buf x]
(-> buf
(f x)
(g x))))
(def ubyte> byte>)
(def short> (integer> 2))
(def ushort> short>)
(def int> (integer> 4))
(def long> (integer> 8))
(def float> (apply> (comp Float/floatToRawIntBits float) int>))
(def double> (apply> Double/doubleToRawLongBits long>))
(defn boolean>
"Writes the byte 1 if 'x' is truthy, else the byte 0."
[buf x]
(if x
(byte> buf 1)
(byte> buf 0)))
(defn varint> [buf n]
(loop [buf buf
n n]
(let [b (bit-and n 0x7F)
nxt (unsigned-bit-shift-right n 7)]
(if (zero? nxt)
(byte> buf b)
(recur (byte> buf (bit-or b 0x80))
nxt)))))
(defn array>
"Returns a writer that writes every value in a coll via 'writer'."
[writer]
(fn [buf xs]
(reduce (fn [acc x]
(writer acc x))
buf xs)))
(defn list>
"Returns a writer that writes every value in a coll via 'writer', preceded
by the varint length of the coll.
When supplied 2 or more key value pairs, writes a collection of maps via map>."
([writer]
(then> (apply> count varint>)
(array> writer)))
([k v & kvs]
(list> (apply map> k v kvs))))
(def bytes> (list> byte>))
(defn string>
"Writes a string as a varint byte length followed by its UTF-8 bytes.
When passed 1 arg, returns a string writer that throws when the string
exceeds the supplied maximum number of UTF-8 bytes."
([max-length]
(fn [buf s]
(if (> (count s) max-length)
(throw (ex-info "Cannot encode string, too long." {:max-length max-length :string s}))
(string> buf s))))
([buf s]
(bytes> buf (String/.getBytes s StandardCharsets/UTF_8))))
(defn identifier>
"Writes an identifier as an encoded string."
[buf identifier]
(string> buf (identifier/encode-identifier identifier)))
(defn split-identifier>
"Writes an identifier as 2 strings: the namespace and the name."
[buf identifier]
(-> buf
(string> (identifier/encode-namespace identifier))
(string> (identifier/encode-name identifier))))
(def json>
"Turns 'x' into JSON and writes it as a string."
(apply> json/write-str string>))
(defn- ->status-response [{::p/keys! [version-name protocol]
::p/keys [motd max-player-count online-player-count]}]
(cond-> {:version {:name version-name
:protocol protocol}}
motd (assoc :description motd)
(and max-player-count online-player-count)
(assoc :players {:max max-player-count
:online online-player-count})))
(def status-response> (apply> ->status-response json>))
(defn uuid> [buf uuid]
{:pre [(uuid? uuid)]}
(-> buf
(long> (UUID/.getMostSignificantBits uuid))
(long> (UUID/.getLeastSignificantBits uuid))))
(defn context-optional>
"Returns a writer that only writes a value via 'writer' if the value is non-nil.
Unlike optional>, is not prefixed with a boolean. Reading is dependent on context."
[writer]
(fn [buf x]
(if (some? x)
(writer buf x)
buf)))
(defn optional>
"Returns a writer that prefixes the value with a boolean indicating whether
it is present, and only writes the value via 'writer' if the value is non-nil."
[writer]
(let [writer (context-optional> writer)]
(fn [buf x]
(-> buf
(boolean> (some? x))
(writer x)))))
(def game-profile> (map> ::p/uuid uuid>
::p/username (string> 16)
::p/game-profile-properties
(list> ::p/game-profile-property-name (string> 64)
::p/game-profile-property-value (string> 32767)
::p/game-profile-property-signature (optional> (string> 1024)))))
(defn- utf-16-code-units [s]
(map int (String/.toCharArray s)))
(defn- write-modified-utf8-byte! [buf code-unit]
(cond (zero? code-unit) (-> buf
(byte> 0xC0)
(byte> 0x80))
(<= 1 code-unit 0x7F) (byte> buf code-unit)
(<= 0x80 code-unit 0x7FF) (-> buf
(byte> (bit-or 0xC0 (bit-shift-right code-unit 6)))
(byte> (bit-or 0x80 (bit-and code-unit 0x3F))))
:else (-> buf
(byte> (bit-or 0xE0 (bit-shift-right code-unit 12)))
(byte> (bit-or 0x80 (bit-and (bit-shift-right code-unit 6) 0x3F)))
(byte> (bit-or 0x80 (bit-and code-unit 0x3F))))))
(defn- write-modified-utf8!
"Writes Java's modified UTF-8 to a buffer.
See https://docs.oracle.com/javase/8/docs/api/java/io/DataInput.html#modified-utf-8"
[buf s]
(reduce write-modified-utf8-byte! buf (utf-16-code-units s)))
(defn nbt-string>
"Writes an NBT string to buf. May take a string, keyword, or protocol identifier.
Strings are prefixed by an unsigned short length, followed by up to 65,535
modified UTF-8 bytes."
[buf s]
(let [s (if (identifier/identifier? s)
(identifier/encode-identifier s)
(name s))]
(-> (ushort> buf (count s))
(write-modified-utf8! s))))
(declare nbt-writer)
(defn nbt-compound>
"Writes an NBT compound from a map.
Compounds are written as 0 or more entries of the map, where each entry
consists of the value's NBT type ID, the NBT string name of the key,
and the encoded value.
The encoded compound ends with the 'tag end' byte (0x0A)."
[buf m]
(-> (reduce (fn [acc [k v]]
(let [t (nbt/type v)]
(-> acc
(byte> (req! nbt/nbt-type->id t))
(nbt-string> (name k))
((nbt-writer t) v))))
buf m)
(byte> (nbt/nbt-type->id ::nbt/tag-end))))
(defn nbt-list>
"Writes a homogeneous list of NBT types.
Lists are prefixed by the ID of their component type"
[buf xs]
(let [nbt-type (nbt/list-type xs)
id (nbt/nbt-type->id nbt-type)
writer (array>
(if (= nbt-type ::nbt/list)
(nbt-writer xs)
(nbt-writer nbt-type)))]
(-> buf
(byte> id)
(int> (count xs))
(writer xs))))
(defn nbt-typed-array>
"Returns a writer for a typed NBT array.
Typed arrays are prefixed by an int length,
followed by 0 or more values of that type."
[writer]
(let [array-writer (array> writer)]
(fn [buf xs]
(-> buf
(int> (count xs))
(array-writer xs)))))
(defn nbt-writer
"Returns a writer for the given NBT type.
Throws if the type is not a valid NBT type."
[nbt-type]
(case nbt-type
::nbt/tag-end byte>
::nbt/boolean boolean>
::nbt/byte byte>
::nbt/short short>
::nbt/int int>
::nbt/long long>
::nbt/float float>
::nbt/double double>
::nbt/byte-array (nbt-typed-array> byte>)
::nbt/string nbt-string>
::nbt/list nbt-list>
::nbt/compound nbt-compound>
::nbt/int-array (nbt-typed-array> int>)
::nbt/long-array (nbt-typed-array> long>)
(throw (ex-info "Can't encode value into NBT."
{:nbt-type nbt-type}))))
(defn nbt>
"Writes an NBT value to buf. Throws if the value is not valid NBT.
NBT in the protocol is prefixed with the byte 0x0A, followed by the type's payload.
See https://minecraft.wiki/w/Minecraft_Wiki:Projects/wiki.vg_merge/NBT#Network_NBT_(Java_Edition)"
[buf x]
(-> buf
(byte> (nbt/nbt-type->id ::nbt/compound))
((nbt-writer (nbt/type x)) x)))