writers.clj
Branches > main > 2783a52 > 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.schema :as p]
[net.bowmap.server.protocol.types :as types])
(: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-field
"Writes a field from map 'm' into 'buf' via 'writer'.
Throws a useful error message when that writing fails."
[writer buf m field]
(try
(writer buf (get m field))
(catch Exception t
(throw (ex-info "Error while writing table field" {:field field
field (get m field)
:writer writer
:table m}
t)))))
(defn table>
"Takes a sequence of alternating keys and writers, e.g.
[:key writer> :key2 writer>].
Returns a writer that takes a map and, for each key/writer pair,
writes the value associated (or nil) with the key using the corresponding writer."
[table]
(let [t (partition 2 table)]
(fn table-writer [buf m]
(reduce (fn [acc [field writer]]
(write-field writer acc m field))
buf t))))
(defn ->writer
"Attempts to coerces 'x' into a writer. Throws if it cannot.
Vectors with pairs of [:key writer] are turned into tables writers.
Nil is not a valid writer."
[x]
(cond
(vector? x) (table> x)
(fn? x) x
:else (throw (ex-info "Cannot coerce into writer." {:x x}))))
(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))))))
(def ubyte> byte>)
(def short> (integer> 2))
(def ushort> short>)
(def int> (integer> 4))
(def long> (integer> 8))
(def float> (apply> Float/floatToRawIntBits 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]
(let [writer (->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
the varint length of the list."
[writer]
(let [array-writer (array> writer)]
(fn [buf xs]
(-> (varint> buf (count xs))
(array-writer xs)))))
(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 'max-length' characters."
([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 split-identifier>
"Writes an identifier as 2 strings: the namespace and the name."
[buf identifier]
(let [{:keys! [namespace name]} (types/identifier-segments identifier)]
(-> buf
(string> namespace)
(string> name))))
(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."
[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]
(boolean> buf (some? x))
(writer buf x))))
(def game-profile> (table> [::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))])]))