writers.clj
Branches > main > b1b0aa7 > files / src / net / bowmap / server / packet / writers.clj
(ns net.bowmap.server.packet.writers
"Functions for writing packet values into a buffer to build up a frame.
Writers are named after the encoding they read, suffixed with >, such as
string>, varint>, etc. Higher order functions like list> and map> build and
return writers
See https://minecraft.wiki/w/Java_Edition_protocol/Packets#Data_types"
(:require
[clojure.data.json :as json]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[net.bowmap.server.game.block :as block]
[net.bowmap.server.game.text :as text]
[net.bowmap.server.packet.identifier :as identifier]
[net.bowmap.server.packet.nbt :as nbt]
[net.bowmap.server.packet.schema :as p])
(:import
[io.netty.buffer ByteBuf ByteBufOutputStream]
[java.nio.charset StandardCharsets]
[java.util UUID]))
(s/def ::writer (s/fspec
:args (s/cat :buf #(instance? ByteBuf %)
:value any?)
:fn #(identical? (-> % :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))))
(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))))))
(def byte> ByteBuf/.writeByte)
(def ubyte> ByteBuf/.writeByte)
(def short> ByteBuf/.writeShort)
(def ushort> ByteBuf/.writeShort)
(def int> ByteBuf/.writeInt)
(def long> ByteBuf/.writeLong)
(def float> (apply> (comp Float/floatToRawIntBits float) int>))
(def double> (apply> Double/doubleToRawLongBits long>))
(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))))
(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))))
(defn- write-string [buf s max-length]
(let [bytes (String/.getBytes s StandardCharsets/UTF_8)]
(if (> (count bytes) max-length)
(throw (ex-info "String exceeds maximum length for writing."
{:max-length max-length
:actual-count (count bytes)
:string s}))
(-> buf
(varint> (count bytes))
(ByteBuf/.writeBytes bytes)))))
(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]
(write-string buf s max-length)))
([buf s]
(write-string buf s ##Inf)))
(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- text->component [{::text/keys [content color extra]}]
(cond-> {:type :text
:text (or content "")}
color (assoc :color color)
(not-empty extra) (assoc :extra (mapv text->component extra))))
(defn- ->status-response [{::p/keys! [version-name version-id]
::p/keys [motd max-player-count online-player-count]}]
(cond-> {:version {:name version-name
:protocol version-id}}
motd (assoc :description (text->component 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 or>
"Returns a writer that writes a value via 'writer', passing 'default'
when the value is nil."
[writer default]
(fn [buf x]
(let [x (if (nil? x) default x)]
(writer buf x))))
(defn enum>
"Returns a writer that writes one of a set of values via 'writer'.
Takes a map of encoded values to decoded values (values that will appear in
the packet map), same as the enum reader. For example, the map {1 :foo}
will write 1 (via 'writer') when given :foo, so the map is 'backwards'.
When the value is not in the enum map, calls 'writer' with nil."
[writer m]
(let [m (set/map-invert m)]
(fn [buf x]
(writer buf (m x)))))
(defn block-location>
"Writes a block location as a 64-bit integer made of 3 signed integers: 26
bits for the x, 26 bits for the y, and 12 bits for the z. Throws if any
of the coordinates do not fit within their respective integer sizes."
[buf {::block/keys! [x y z]}]
{:pre [(<= (Math/pow -2 25) x (- (Math/pow 2 25) 1))
(<= (Math/pow -2 25) z (- (Math/pow 2 25) 1))
(<= (Math/pow -2 11) y (- (Math/pow 2 11) 1))]}
(long> buf
(bit-or
(bit-shift-left (bit-and x 0x3FFFFFF) 38)
(bit-shift-left (bit-and z 0x3FFFFFF) 12)
(bit-and y 0xFFF))))
(defn nbt-string>
"Writes an NBT string to buf. May take a string, keyword, or packet 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))]
(doto buf
(-> (ByteBufOutputStream.)
(ByteBufOutputStream/.writeUTF 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.
Encoded NBT 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)))